/* Flowlog - automatically parallel prolog * * Single-file build: * cc -O2 -Wall -Wextra -pthread flowlog.c -lm -o flowlog * * Layout system: * - Sections are marked with "SECTION NN:" headers and `====` rulers. * - Subsections are marked with "SUBSECTION NN.N:" headers and `---` rulers. * - Search for "SECTION 10" or "SUBSECTION 10.2" to jump. * * Layout (in file order): * 01. User-Configurable Defaults * 02. Platform & Base Types * 03. Encoding & Text Utilities * 04. Runtime Detection & Signals * 05. Core Runtime Types * 06. Runtime Globals & Diagnostics * 07. Parallel Runtime State & Thread Pool * 08. Streams & I/O State * 09. Memory & Allocation * 10. Lexer & Parser * 11. Packed Strings & List-Like Helpers * 12. Term Equality & List Helpers * 13. Program DB & Indexing * 14. Interpreter Term Ops & Unification * 15. WAM Term Ops & Arithmetic * 16. Term Order & Comparison * 17. Term Writer & Reader * 18. WAMVM Instantiation & Bytecode Model * 19. Exceptions & Errors * 20. Tabling * 21. Parallel OR/AND Jobs * 22. Interpreter Solver & Builtins * 23. WAM-lite Solver * 24. WAMVM VM * 25. CLI Source Loading * 26. CLI & REPL * * The binary defaults to: * - engine: wamvm * - parallel profile: fast (unordered OR-par commits for throughput) * * Use `--engine interp` (or `--engine tree`) and/or `--parallel-profile iso|off` * to prioritize classic behavior and determinism over throughput. * * ^ ^ * =(o.o)= * m m * ~byakuren */ /* ============================================================================ * SECTION 01: User-Configurable Defaults * compile-time overrides for single-file builds. * ============================================================================ */ // Preferred runtime overrides (instead of editing this file): // - CLI: `--threads N` // - env: FLOWLOG_N_CPUPROC, FLOWLOG_ORPAR_MAX_WORKERS, FLOWLOG_ORPAR_STACK_SIZE, // FLOWLOG_STACK_BOOST, FLOWLOG_MAIN_STACK_SIZE, FLOWLOG_CSTACK_LIMIT, // FLOWLOG_HISTORY_FILE, FLOWLOG_RC_FILE, FLOWLOG_POOL_LOCAL_ALLOC, FLOWLOG_DEBUG_ORPAR, ... /* --- SUBSECTION 01.1: Version & Limits ----------------------------------- */ // Build-time version string and safety limits for recursion, tracing, and CPU caps. // Defines FLOWLOG_VERSION_STRING plus FLOWLOG_DEFAULT_CPU_CAP and depth/trace limit macros. #ifndef FLOWLOG_VERSION_STRING #define FLOWLOG_VERSION_STRING "Flowlog (v4.8.2)" #endif // Cap auto-detected CPU count (0 = no cap). Explicit `--threads`/FLOWLOG_N_CPUPROC win. #ifndef FLOWLOG_DEFAULT_CPU_CAP #define FLOWLOG_DEFAULT_CPU_CAP 0 #endif // Safety recursion limit for internal term/goal traversals (0 = unlimited). #ifndef FLOWLOG_DEPTH_LIMIT #define FLOWLOG_DEPTH_LIMIT 0 #endif // Safety recursion limit for the main solver (goal stack depth). ISO Prolog code // can legitimately recurse far deeper than FLOWLOG_DEPTH_LIMIT (e.g. list // processing on large lists), so this defaults to unlimited. #ifndef FLOWLOG_SOLVE_DEPTH_LIMIT #define FLOWLOG_SOLVE_DEPTH_LIMIT 0 #endif // Trace stack depth; affects SIGINFO stack output (0 = unlimited). #ifndef FLOWLOG_TRACE_MAX_DEPTH #define FLOWLOG_TRACE_MAX_DEPTH 0 #endif /* --- SUBSECTION 01.2: Parallel Tuning Defaults --------------------------- */ // Parallel scheduling defaults and stack sizing knobs for OR/AND-par. // FLOWLOG_DEFAULT_PARALLEL_* and FLOWLOG_ORPAR_* thresholds tune spawn depth, lookahead, and stacks. // Runtime default is adaptive when flowlog_parallel_max_depth is not explicitly // set: max(24, 3 * threads), capped by FLOWLOG_DEFAULT_PARALLEL_MAX_DEPTH. // Recommended cap value: 128-core systems -> 128; 8-core systems auto-resolve // to 24 via the adaptive rule above. #ifndef FLOWLOG_DEFAULT_PARALLEL_MAX_DEPTH #define FLOWLOG_DEFAULT_PARALLEL_MAX_DEPTH 128 #endif // Default `flowlog_parallel_or_nesting` (0 = top-level OR-par only). #ifndef FLOWLOG_DEFAULT_PARALLEL_OR_NESTING #define FLOWLOG_DEFAULT_PARALLEL_OR_NESTING 16 #endif // Default OR-par nesting depth for `flowlog_parallel_profile=fast`. #ifndef FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST #define FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST 16 #endif // OR-par heuristics. // // OR-par has non-trivial scheduling/marshalling overhead. These thresholds try // to ensure Flowlog only spawns OR-par work when there is enough branching to // amortize overhead. // // Depth-based spawning is capped by `flowlog_parallel_max_depth`, but large // choicepoints can be worth parallelizing even when they occur deeper in the // goal sequence. `FLOWLOG_ORPAR_BIG_ALT_THRESHOLD` enables this "deep OR-par" // escape hatch for coarse choicepoints (big fact tables, seed splitters, etc.) // while still preventing runaway spawning for tiny recursive predicates. #ifndef FLOWLOG_ORPAR_BIG_ALT_THRESHOLD #define FLOWLOG_ORPAR_BIG_ALT_THRESHOLD 64 #endif // Minimum alternative count required before attempting OR-par at all. #ifndef FLOWLOG_ORPAR_MIN_ALT_THRESHOLD #define FLOWLOG_ORPAR_MIN_ALT_THRESHOLD 8 #endif // Cap worker count so each worker receives a reasonable amount of work. #ifndef FLOWLOG_ORPAR_MIN_ALTS_PER_WORKER #define FLOWLOG_ORPAR_MIN_ALTS_PER_WORKER 16 #endif // Ordered OR-par must commit solutions in increasing alternative order. Limit // speculation so workers don't run too far ahead and waste work. #ifndef FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MULT #define FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MULT 4 #endif #ifndef FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MIN #define FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MIN 16 #endif #ifndef FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MAX #define FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MAX 2048 #endif // AND-par heuristics. #ifndef FLOWLOG_PAR_AND_MAX_BATCH #define FLOWLOG_PAR_AND_MAX_BATCH 8 #endif // OR-par pthread stack sizing (used when FLOWLOG_ORPAR_STACK_SIZE is not set). #ifndef FLOWLOG_ORPAR_STACK_MAX_BYTES #define FLOWLOG_ORPAR_STACK_MAX_BYTES ((size_t)128u * 1024u * 1024u) #endif #ifndef FLOWLOG_ORPAR_STACK_MIN_BYTES #define FLOWLOG_ORPAR_STACK_MIN_BYTES ((size_t)8u * 1024u * 1024u) #endif #ifndef FLOWLOG_ORPAR_STACK_MEM_BUDGET_DIV #define FLOWLOG_ORPAR_STACK_MEM_BUDGET_DIV 8 #endif /* --- SUBSECTION 01.3: REPL/History/RC Defaults --------------------------- */ // REPL history/rc defaults for filename suffixes and history capacity. // FLOWLOG_HISTORY_DEFAULT_SUFFIX, FLOWLOG_RC_DEFAULT_SUFFIX, and // FLOWLOG_HISTORY_INITIAL_CAP feed repl startup helpers. #ifndef FLOWLOG_HISTORY_DEFAULT_SUFFIX #define FLOWLOG_HISTORY_DEFAULT_SUFFIX "/.flowlog_history" #endif #ifndef FLOWLOG_RC_DEFAULT_SUFFIX #define FLOWLOG_RC_DEFAULT_SUFFIX "/.flowlogrc" #endif #ifndef FLOWLOG_HISTORY_INITIAL_CAP #define FLOWLOG_HISTORY_INITIAL_CAP 128 #endif /* --- SUBSECTION 01.4: Indexing/Heuristic Tweaks -------------------------- */ // Indexing and heuristic thresholds for candidate selection and select/1 OR-par. // FLOWLOG_SELECT1_ORPAR_DEEP_THRESHOLD and FLOWLOG_PRED_CANDS_DIRECT_MAX choose indexing vs scans. #ifndef FLOWLOG_SELECT1_ORPAR_DEEP_THRESHOLD #define FLOWLOG_SELECT1_ORPAR_DEEP_THRESHOLD 8 #endif // Candidate selection: for very small predicates, indexing overhead can exceed // the cost of simply trying clauses in order. When a predicate has <= this many // clauses, return its full clause list directly (no constraint building/copy). #ifndef FLOWLOG_PRED_CANDS_DIRECT_MAX #define FLOWLOG_PRED_CANDS_DIRECT_MAX 16 #endif /* ============================================================================ * SECTION 02: Platform & Base Types * system headers, portability macros, and base typedefs. * ============================================================================ */ /* --- SUBSECTION 02.1: System Includes ------------------------------------ */ // Standard C/POSIX headers for runtime, parser, IO, and threading. // Brings in mmap, pthreads, signals, and sysconf used throughout the file. #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include /* --- SUBSECTION 02.2: Portability Macros --------------------------------- */ // Portability shims for MAP_ANON and thread-local storage. // Defines MAP_ANON and FLOWLOG_TLS to smooth libc/OS differences. #ifndef MAP_ANON #ifdef MAP_ANONYMOUS #define MAP_ANON MAP_ANONYMOUS #endif #endif #ifndef FLOWLOG_TLS #if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 201112L) #define FLOWLOG_TLS _Thread_local #elif defined(__GNUC__) || defined(__clang__) #define FLOWLOG_TLS __thread #else #define FLOWLOG_TLS #endif #endif /* --- SUBSECTION 02.3: Base Typedefs -------------------------------------- */ // Base typedefs for string/byte/integer sizing across the runtime. // CHR/UCH/ULO/SLO anchor char storage and index math. typedef char CHR; typedef unsigned char UCH; typedef unsigned long ULO; typedef long SLO; /* --- SUBSECTION 02.4: Depth Limit Helpers -------------------------------- */ // Depth-limit helpers: limit=0 disables the corresponding cap. static inline bool flowlog_depth_limit_exceeded_ulo(ULO depth, ULO limit) { return (limit != 0) && (depth > limit); } static inline bool flowlog_depth_limit_reached_ulo(ULO depth, ULO limit) { return (limit != 0) && (depth >= limit); } #define FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, limit) \ flowlog_depth_limit_exceeded_ulo((ULO)(depth), (ULO)(limit)) #define FLOWLOG_DEPTH_LIMIT_REACHED(depth, limit) \ flowlog_depth_limit_reached_ulo((ULO)(depth), (ULO)(limit)) /* ============================================================================ * SECTION 03: Encoding & Text Utilities * UTF-8 encode/decode helpers and validation routines. * ============================================================================ */ /* --- SUBSECTION 03.1: UTF-8 Encode/Decode ------------------------------- */ // UTF-8 encode/decode primitives used by packed strings and IO. // unicode_codepoint_valid(), utf8_encode_one(), utf8_decode_one_lenient(), and utf8_count_codepoints_lenient() convert codepoints. #define PL_UTF8_MAX_BYTES 4 #define PL_UTF8_REPLACEMENT 0xFFFDu static inline bool unicode_codepoint_valid(uint32_t cp) { return (cp > 0) && (cp <= 0x10FFFFu) && !((cp >= 0xD800u) && (cp <= 0xDFFFu)); } static inline size_t utf8_encode_one(uint32_t cp, unsigned char *out, size_t cap) { if (!unicode_codepoint_valid(cp)) { cp = PL_UTF8_REPLACEMENT; } if (cp <= 0x7Fu) { if (out && cap >= 1) { out[0] = (unsigned char)cp; } return 1; } if (cp <= 0x7FFu) { if (out && cap >= 2) { out[0] = (unsigned char)(0xC0u | (cp >> 6)); out[1] = (unsigned char)(0x80u | (cp & 0x3Fu)); } return 2; } if (cp <= 0xFFFFu) { if (out && cap >= 3) { out[0] = (unsigned char)(0xE0u | (cp >> 12)); out[1] = (unsigned char)(0x80u | ((cp >> 6) & 0x3Fu)); out[2] = (unsigned char)(0x80u | (cp & 0x3Fu)); } return 3; } if (out && cap >= 4) { out[0] = (unsigned char)(0xF0u | (cp >> 18)); out[1] = (unsigned char)(0x80u | ((cp >> 12) & 0x3Fu)); out[2] = (unsigned char)(0x80u | ((cp >> 6) & 0x3Fu)); out[3] = (unsigned char)(0x80u | (cp & 0x3Fu)); } return 4; } static inline size_t utf8_decode_one_lenient(const unsigned char *s, size_t len, uint32_t *out_cp) { if (!s || !len || !out_cp) { return 0; } const unsigned char b0 = s[0]; if (b0 < 0x80u) { *out_cp = (uint32_t)b0; return 1; } if ((b0 & 0xE0u) == 0xC0u) { if (len >= 2) { const unsigned char b1 = s[1]; if ((b1 & 0xC0u) == 0x80u) { const uint32_t cp = ((uint32_t)(b0 & 0x1Fu) << 6) | (uint32_t)(b1 & 0x3Fu); if (cp >= 0x80u) { *out_cp = cp; return 2; } } } } else if ((b0 & 0xF0u) == 0xE0u) { if (len >= 3) { const unsigned char b1 = s[1]; const unsigned char b2 = s[2]; if (((b1 & 0xC0u) == 0x80u) && ((b2 & 0xC0u) == 0x80u)) { const uint32_t cp = ((uint32_t)(b0 & 0x0Fu) << 12) | ((uint32_t)(b1 & 0x3Fu) << 6) | (uint32_t)(b2 & 0x3Fu); if ((cp >= 0x800u) && !((cp >= 0xD800u) && (cp <= 0xDFFFu))) { *out_cp = cp; return 3; } } } } else if ((b0 & 0xF8u) == 0xF0u) { if (len >= 4) { const unsigned char b1 = s[1]; const unsigned char b2 = s[2]; const unsigned char b3 = s[3]; if (((b1 & 0xC0u) == 0x80u) && ((b2 & 0xC0u) == 0x80u) && ((b3 & 0xC0u) == 0x80u)) { const uint32_t cp = ((uint32_t)(b0 & 0x07u) << 18) | ((uint32_t)(b1 & 0x3Fu) << 12) | ((uint32_t)(b2 & 0x3Fu) << 6) | (uint32_t)(b3 & 0x3Fu); if ((cp >= 0x10000u) && (cp <= 0x10FFFFu)) { *out_cp = cp; return 4; } } } } *out_cp = PL_UTF8_REPLACEMENT; return 1; } static inline ULO utf8_count_codepoints_lenient(const unsigned char *s, ULO len) { if (!s || !len) { return 0; } ULO count = 0; ULO off = 0; while (off < len) { uint32_t cp = 0; const size_t used = utf8_decode_one_lenient(s + off, (size_t)(len - off), &cp); if (!used) { break; } count++; off += (ULO)used; } return count; } static inline ULO utf8_decode_into(const unsigned char *src, ULO len, uint32_t *dst, ULO dst_cap) { if (!src || !len || !dst || !dst_cap) { return 0; } ULO count = 0; ULO off = 0; while (off < len && count < dst_cap) { uint32_t cp = 0; const size_t used = utf8_decode_one_lenient(src + off, (size_t)(len - off), &cp); if (!used) { break; } dst[count++] = cp; off += (ULO)used; } return count; } static inline bool utf8_decode_one_strict(const unsigned char *s, size_t len, uint32_t *out_cp, size_t *out_used) { if (!s || !len || !out_cp || !out_used) { return false; } const unsigned char b0 = s[0]; if (b0 == 0) { return false; } if (b0 < 0x80u) { *out_cp = (uint32_t)b0; *out_used = 1; return true; } if ((b0 & 0xE0u) == 0xC0u) { if (len < 2) { return false; } if (b0 < 0xC2u) { return false; // overlong } const unsigned char b1 = s[1]; if ((b1 & 0xC0u) != 0x80u) { return false; } const uint32_t cp = ((uint32_t)(b0 & 0x1Fu) << 6) | (uint32_t)(b1 & 0x3Fu); if (!unicode_codepoint_valid(cp)) { return false; } *out_cp = cp; *out_used = 2; return true; } if ((b0 & 0xF0u) == 0xE0u) { if (len < 3) { return false; } const unsigned char b1 = s[1]; const unsigned char b2 = s[2]; if ((b1 & 0xC0u) != 0x80u || (b2 & 0xC0u) != 0x80u) { return false; } if ((b0 == 0xE0u && b1 < 0xA0u) || (b0 == 0xEDu && b1 >= 0xA0u)) { return false; } const uint32_t cp = ((uint32_t)(b0 & 0x0Fu) << 12) | ((uint32_t)(b1 & 0x3Fu) << 6) | (uint32_t)(b2 & 0x3Fu); if (!unicode_codepoint_valid(cp)) { return false; } *out_cp = cp; *out_used = 3; return true; } if ((b0 & 0xF8u) == 0xF0u) { if (len < 4) { return false; } if (b0 > 0xF4u) { return false; } const unsigned char b1 = s[1]; const unsigned char b2 = s[2]; const unsigned char b3 = s[3]; if ((b1 & 0xC0u) != 0x80u || (b2 & 0xC0u) != 0x80u || (b3 & 0xC0u) != 0x80u) { return false; } if ((b0 == 0xF0u && b1 < 0x90u) || (b0 == 0xF4u && b1 >= 0x90u)) { return false; } const uint32_t cp = ((uint32_t)(b0 & 0x07u) << 18) | ((uint32_t)(b1 & 0x3Fu) << 12) | ((uint32_t)(b2 & 0x3Fu) << 6) | (uint32_t)(b3 & 0x3Fu); if (!unicode_codepoint_valid(cp)) { return false; } *out_cp = cp; *out_used = 4; return true; } return false; } /* --- SUBSECTION 03.2: UTF-8 Validation Helpers --------------------------- */ // UTF-8 validation for file and stream input. // utf8_validate_no_nul() checks for invalid byte sequences and rejects embedded NULs. static bool utf8_validate_no_nul(const unsigned char *s, size_t len) { if (!s && len) { return false; } size_t off = 0; while (off < len) { uint32_t cp = 0; size_t used = 0; if (!utf8_decode_one_strict(s + off, len - off, &cp, &used)) { return false; } off += used; } return true; } /* ============================================================================ * SECTION 04: Runtime Detection & Signals * runtime constants, CPU/RAM detection, and signal handling. * ============================================================================ */ /* --- SUBSECTION 04.1: Version & Core Helpers ----------------------------- */ // Core runtime helpers and allocation wrappers. // FLOWLOG_VERSION exports version; rise_error_info_dbg() reports fatal errors; reallocpool()/freepool() wrap heap use. static const char *FLOWLOG_VERSION = FLOWLOG_VERSION_STRING; static void rise_error_info_dbg(int code, const char *msg, const ULO *dbg_dat_ptr) { (void)dbg_dat_ptr; (void)fprintf(stderr, "flowlog: fatal error (%d): %s\n", code, msg ? msg : "unknown error"); exit(1); } static void *reallocpool(void *ptr, ULO size) { if (!size) { size = 1; } return realloc(ptr, (size_t)size); } static void freepool(void *ptr) { free(ptr); } /* --- SUBSECTION 04.2: CPU/RAM Detection ---------------------------------- */ // CPU and RAM detection cached for scheduling decisions. // flowlog_detect_ncpuproc(), flowlog_detect_phys_mem_bytes(), and flowlog_phys_mem_bytes() compute caps for threads/stacks. static ULO g_ncpuproc_override = 0; static ULO g_detected_ncpuproc = 0; static ULO flowlog_detect_ncpuproc(void) { long n = sysconf(_SC_NPROCESSORS_ONLN); if (n > 0 && n < LONG_MAX) { ULO v = (ULO)n; #if FLOWLOG_DEFAULT_CPU_CAP > 0 if (v > (ULO)FLOWLOG_DEFAULT_CPU_CAP) { v = (ULO)FLOWLOG_DEFAULT_CPU_CAP; } #endif return v; } return 1; } // Cache physical memory size; 1 means "unknown/unavailable" sentinel. static uint64_t g_detected_phys_mem_bytes = 0; static uint64_t flowlog_detect_phys_mem_bytes(void) { long pages = -1; long page_sz = -1; #ifdef _SC_PHYS_PAGES pages = sysconf(_SC_PHYS_PAGES); #endif #if defined(_SC_PAGESIZE) page_sz = sysconf(_SC_PAGESIZE); #elif defined(_SC_PAGE_SIZE) page_sz = sysconf(_SC_PAGE_SIZE); #endif if (pages <= 0 || page_sz <= 0) { return 0; } const uint64_t p = (uint64_t)(unsigned long)pages; const uint64_t s = (uint64_t)(unsigned long)page_sz; return p * s; } static uint64_t flowlog_phys_mem_bytes(void) { if (!g_detected_phys_mem_bytes) { const uint64_t v = flowlog_detect_phys_mem_bytes(); g_detected_phys_mem_bytes = v ? v : 1; } return (g_detected_phys_mem_bytes == 1) ? 0 : g_detected_phys_mem_bytes; } /* --- SUBSECTION 04.3: Signal Handling ------------------------------------ */ // Signal handling and stack sizing helpers for diagnostics. // flowlog_sigint_handler(), flowlog_siginfo_handler(), flowlog_siginfo_take(), and SIGSEGV install helpers coordinate interrupts. static volatile sig_atomic_t g_sigint_pending = 0; static void flowlog_sigint_handler(int signum) { (void)signum; g_sigint_pending = 1; } #if defined(SIGSEGV) static void flowlog_sigsegv_trace_handler(int signum, siginfo_t *info, void *uctx); static void flowlog_install_sigsegv_trace_handler(bool enabled); #endif #if defined(SIGINFO) static volatile sig_atomic_t g_siginfo_pending = 0; static void flowlog_siginfo_handler(int signum) { (void)signum; g_siginfo_pending = 1; } static inline bool flowlog_siginfo_take(void) { if (!g_siginfo_pending) { return false; } g_siginfo_pending = 0; return true; } #else static inline bool flowlog_siginfo_take(void) { return false; } #endif static void flowlog_install_signal_handlers(void) { struct sigaction sa; memset(&sa, 0, sizeof(sa)); sa.sa_handler = flowlog_sigint_handler; (void)sigemptyset(&sa.sa_mask); // Prefer restarting interrupted syscalls so stdio doesn't enter an error // state when SIGINT is delivered (REPLs and pipe-driven tests rely on this). #ifdef SA_RESTART sa.sa_flags = SA_RESTART; #else sa.sa_flags = 0; #endif (void)sigaction(SIGINT, &sa, NULL); #if defined(SIGINFO) struct sigaction ia; memset(&ia, 0, sizeof(ia)); ia.sa_handler = flowlog_siginfo_handler; (void)sigemptyset(&ia.sa_mask); #ifdef SA_RESTART ia.sa_flags = SA_RESTART; // SIGINFO should not break blocking I/O #else ia.sa_flags = 0; #endif (void)sigaction(SIGINFO, &ia, NULL); #endif // Some shells (and especially background/coproc jobs) may start child // processes with SIGINT blocked. Ensure it is unblocked so Ctrl-C / SIGINT // can always be used to interrupt long-running queries. sigset_t set; (void)sigemptyset(&set); (void)sigaddset(&set, SIGINT); #if defined(SIGINFO) (void)sigaddset(&set, SIGINFO); #endif (void)pthread_sigmask(SIG_UNBLOCK, &set, NULL); } static inline bool flowlog_interrupted(void) { return g_sigint_pending != 0; } static inline void flowlog_interrupt_clear(void) { g_sigint_pending = 0; } static size_t flowlog_default_orpar_stack_size_bytes(ULO thread_count) { const size_t max_stack = (size_t)FLOWLOG_ORPAR_STACK_MAX_BYTES; const size_t min_stack = (size_t)FLOWLOG_ORPAR_STACK_MIN_BYTES; size_t stack_sz = max_stack; const uint64_t mem = flowlog_phys_mem_bytes(); if (mem && thread_count > 0) { // Keep total OR-par stack reservation to a conservative fraction of physical memory. // (Stacks are usually demand-paged, but some OS/libpthread configurations commit more eagerly.) const uint64_t budget = mem / (uint64_t)FLOWLOG_ORPAR_STACK_MEM_BUDGET_DIV; const uint64_t per = budget / (uint64_t)thread_count; if (per > 0 && per < (uint64_t)stack_sz) { stack_sz = (size_t)per; } } if (stack_sz < min_stack) { stack_sz = min_stack; } if (stack_sz < (size_t)PTHREAD_STACK_MIN) { stack_sz = (size_t)PTHREAD_STACK_MIN; } long page_sz = -1; #if defined(_SC_PAGESIZE) page_sz = sysconf(_SC_PAGESIZE); #elif defined(_SC_PAGE_SIZE) page_sz = sysconf(_SC_PAGE_SIZE); #endif if (page_sz > 0) { const size_t p = (size_t)page_sz; stack_sz = ((stack_sz + p - 1) / p) * p; } return stack_sz; } static ULO get_n_cpuproc(void) { if (g_ncpuproc_override > 0) { return g_ncpuproc_override; } if (!g_detected_ncpuproc) { g_detected_ncpuproc = flowlog_detect_ncpuproc(); } return g_detected_ncpuproc ? g_detected_ncpuproc : 1; } // Adaptive default for flowlog_parallel_max_depth: // scale with worker count, keep low-core systems shallow enough to avoid // overspawn, and cap by the compile-time default. static SLO flowlog_default_parallel_max_depth_auto(void) { ULO ncpu = get_n_cpuproc(); if (!ncpu) { ncpu = 1; } // Empirical anchor points from bench/compare_nqueens.sh: // 8 cores -> 24, high-core hosts trend toward the compile-time cap. ULO depth = ncpu * 3u; if (depth < 24u) { depth = 24u; } #if FLOWLOG_DEFAULT_PARALLEL_MAX_DEPTH > 0 if (depth > (ULO)FLOWLOG_DEFAULT_PARALLEL_MAX_DEPTH) { depth = (ULO)FLOWLOG_DEFAULT_PARALLEL_MAX_DEPTH; } #endif if (depth > (ULO)LONG_MAX) { depth = (ULO)LONG_MAX; } return (SLO)depth; } static int am_I_in_the_CPUPROC_module(void) { return 1; } static ULO get_id_cpuproc_fast(const void *rt_ctrl) { (void)rt_ctrl; return 0; } static ULO get_id_taskjob_fast(const void *rt_ctrl) { (void)rt_ctrl; return 0; } static ULO get_n_taskjob(void) { return 1; } static void setup_thread_safe_functionality_for_local_thread(void) {} static void cleanup_thread_safe_functionality_for_local_thread(void) {} /* ============================================================================ * SECTION 05: Core Runtime Types * core term tags, program structures, and builtin identifiers. * ============================================================================ */ /* --- SUBSECTION 05.1: Error Codes & Tags --------------------------------- */ // Runtime error code constants for parsers and allocators. // ECODE_RT__FLOWLOG_* values are passed into rise_error_info_dbg() on fatal failures. enum { ECODE_RT__FLOWLOG_PARSE = 240, ECODE_RT__FLOWLOG_OOM = 241, ECODE_RT__FLOWLOG_TYPE = 242, }; /* --- SUBSECTION 05.2: Term Tags & Core Structs --------------------------- */ // Core term tags and structures for atoms, numbers, vars, structs, and packed strings. // Defines pl_term/pl_term_struct/pl_term_pstr, pl_double_quotes_mode, pl_engine_mode, and pl_wam_cell layout. // pl_number tracks integer/float/bigint values during evaluation to avoid early promotion. typedef enum { PL_TERM_ATOM = 1, PL_TERM_INT = 2, PL_TERM_FLOAT = 3, PL_TERM_VAR = 4, PL_TERM_STRUCT = 5, PL_TERM_PSTR = 6, // packed string (list-equivalent representation) PL_TERM_BIGINT = 7, } pl_term_tag; typedef struct pl_term pl_term; typedef struct pl_scope pl_scope; typedef struct pl_env pl_env; typedef struct pl_init_goal pl_init_goal; typedef struct pl_op_overrides pl_op_overrides; typedef struct pl_dyn_pred pl_dyn_pred; typedef struct pl_pred_index pl_pred_index; typedef struct pl_program_argv_src pl_program_argv_src; typedef struct pl_sbuf pl_sbuf; typedef struct pl_table_state pl_table_state; typedef struct pl_tabled_subgoal pl_tabled_subgoal; typedef struct pl_temp_snapshot pl_temp_snapshot; typedef struct pl_bigint pl_bigint; typedef struct pl_wam_cell { pl_term *value; // NULL when unbound } pl_wam_cell; typedef enum { PL_UNKNOWN_ERROR = 0, PL_UNKNOWN_WARNING = 1, PL_UNKNOWN_FAIL = 2, } pl_unknown_mode; typedef enum { PL_DQ_ATOM = 0, PL_DQ_CODES = 1, PL_DQ_CHARS = 2, } pl_double_quotes_mode; typedef enum { PL_OR_ORDERED = 0, PL_OR_UNORDERED = 1, } pl_or_order_mode; typedef enum { PL_ENGINE_INTERP = 0, PL_ENGINE_WAM = 1, PL_ENGINE_WAMVM = 2, } pl_engine_mode; struct pl_scope { ULO reserved; // Optional hint for engines that need to pre-wire variable cells (e.g. WAM // tabling answer scopes). 0 means "unknown/unspecified". ULO var_count; }; typedef struct { ULO arity; CHR *functor; pl_term **args; } pl_term_struct; typedef struct { // Packed list-of-chars representation. // // `bytes` points to a NUL-terminated run of UTF-8 bytes, followed by padding // zeros up to pointer alignment, followed by a single `pl_term*` cell that // stores the list tail: // - [] for a complete string // - a variable for a partial string // - another (partial) packed string term // // This enables list-equivalent traversal without storing a length, and allows // constant-time concatenation via tail unification. // // see: https://www.youtube.com/watch?v=plvBFNi0cVw const unsigned char *bytes; } pl_term_pstr; struct pl_term { pl_term_tag tag; uint16_t builtin; // cached built-in predicate id (name/arity), 0 when none/unknown uint16_t reserved16; // padding/reserved (keeps union aligned) union { CHR *atom_name; SLO int_value; double float_value; pl_bigint *bigint; struct { const pl_scope *scope; ULO var_id; CHR *var_name; } var; pl_term_struct str; pl_term_pstr pstr; } v; }; static inline bool term_is_integer(const pl_term *t) { return t && (t->tag == PL_TERM_INT || t->tag == PL_TERM_BIGINT); } static inline bool term_is_number(const pl_term *t) { return t && (term_is_integer(t) || t->tag == PL_TERM_FLOAT); } static inline bool term_is_atomic_term(const pl_term *t) { return t && (t->tag == PL_TERM_ATOM || term_is_number(t)); } static int bigint_cmp(const pl_bigint *a, const pl_bigint *b); static int bigint_cmp_slo(const pl_bigint *a, SLO b); static bool bigint_fits_slo(const pl_bigint *b, SLO *out); static pl_bigint *bigint_from_cstr_base(const CHR *s, size_t len, int base, int sign, const void *rt_ctrl, const ULO *dbg_dat_ptr); static pl_bigint *bigint_negate(const pl_bigint *a, const void *rt_ctrl, const ULO *dbg_dat_ptr); static inline bool term_integer_equal(const pl_term *a, const pl_term *b) { if (!term_is_integer(a) || !term_is_integer(b)) { return false; } if (a->tag == PL_TERM_INT && b->tag == PL_TERM_INT) { return a->v.int_value == b->v.int_value; } if (a->tag == PL_TERM_BIGINT && b->tag == PL_TERM_BIGINT) { return bigint_cmp(a->v.bigint, b->v.bigint) == 0; } if (a->tag == PL_TERM_BIGINT) { return bigint_cmp_slo(a->v.bigint, b->v.int_value) == 0; } return bigint_cmp_slo(b->v.bigint, a->v.int_value) == 0; } static inline int term_integer_cmp(const pl_term *a, const pl_term *b) { if (a->tag == PL_TERM_INT && b->tag == PL_TERM_INT) { if (a->v.int_value < b->v.int_value) { return -1; } if (a->v.int_value > b->v.int_value) { return 1; } return 0; } if (a->tag == PL_TERM_BIGINT && b->tag == PL_TERM_BIGINT) { return bigint_cmp(a->v.bigint, b->v.bigint); } if (a->tag == PL_TERM_BIGINT) { return bigint_cmp_slo(a->v.bigint, b->v.int_value); } return -bigint_cmp_slo(b->v.bigint, a->v.int_value); } /* --- SUBSECTION 05.3: Builtin & Arithmetic Identifiers ------------------- */ // Builtin predicate IDs and arithmetic IDs for fast dispatch. // builtin_id_from_name_arity() and arith_id_from_name_arity() map names to cached ids stored in pl_term metadata. typedef enum { PL_BI_NONE = 0, PL_BI_TRUE_0, PL_BI_FAIL_0, PL_BI_FALSE_0, PL_BI_HALT_0, PL_BI_CUT_0, PL_BI_REPEAT_0, PL_BI_NL_0, PL_BI_FLUSH_OUTPUT_0, PL_BI_NOT_1, PL_BI_DROP_BARRIER_1, PL_BI_DROP_EXC_BARRIER_1, PL_BI_IF_BARRIER_2, PL_BI_ARROW_2, PL_BI_COMMA_2, PL_BI_SEMI_2, PL_BI_UNIFY_2, PL_BI_NOT_UNIFY_2, PL_BI_IDENTICAL_2, PL_BI_NOT_IDENTICAL_2, PL_BI_VARIANT_2, PL_BI_NOT_VARIANT_2, PL_BI_TERM_LT_2, PL_BI_TERM_LTE_2, PL_BI_TERM_GT_2, PL_BI_TERM_GTE_2, PL_BI_IS_2, PL_BI_NUM_EQ_2, PL_BI_NUM_NE_2, PL_BI_NUM_LT_2, PL_BI_NUM_LTE_2, PL_BI_NUM_GT_2, PL_BI_NUM_GTE_2, } pl_builtin_id; // Cached evaluable-function ids for arithmetic evaluation (used by is/2 and // numeric comparisons). Stored in pl_term.reserved16 for terms that are // arithmetic expressions (and for a few numeric constant atoms like pi/0). typedef enum { PL_ARITH_NONE = 0, // numeric constants (atom/0) PL_ARITH_PI_0, PL_ARITH_E_0, PL_ARITH_EPSILON_0, // arithmetic operators / functions PL_ARITH_ADD_2, PL_ARITH_ADD_1, PL_ARITH_SUB_2, PL_ARITH_SUB_1, PL_ARITH_MUL_2, PL_ARITH_DIV_2, PL_ARITH_INTDIV_2, // '//' (trunc toward 0) PL_ARITH_REM_2, PL_ARITH_DIV_2_FLOOR, // div PL_ARITH_MOD_2, // mod PL_ARITH_ABS_1, PL_ARITH_SIGN_1, PL_ARITH_FLOOR_1, PL_ARITH_CEILING_1, PL_ARITH_TRUNCATE_1, PL_ARITH_ROUND_1, PL_ARITH_FLOAT_INTEGER_PART_1, PL_ARITH_FLOAT_FRACTIONAL_PART_1, PL_ARITH_FLOAT_1, PL_ARITH_MIN_2, PL_ARITH_MAX_2, // bitwise / shifts PL_ARITH_BNOT_1, // '\'(X) PL_ARITH_BAND_2, // '/\'(A,B) PL_ARITH_BOR_2, // '\/'(A,B) PL_ARITH_BXOR_2, // xor(A,B) PL_ARITH_SHL_2, // '<<'(A,B) PL_ARITH_SHR_2, // '>>'(A,B) // exponentiation / power PL_ARITH_POWF_2, // '**'(A,B) PL_ARITH_POWI_2, // '^'(A,B) // trig / misc float ops PL_ARITH_SIN_1, PL_ARITH_COS_1, PL_ARITH_TAN_1, PL_ARITH_ASIN_1, PL_ARITH_ACOS_1, PL_ARITH_ATAN_1, PL_ARITH_SQRT_1, PL_ARITH_LOG_1, PL_ARITH_EXP_1, PL_ARITH_ATAN2_2, } pl_arith_id; static uint16_t builtin_id_from_name_arity(const CHR *name, ULO arity) { if (!name) { return (uint16_t)PL_BI_NONE; } if (arity == 0) { if (!strcmp(name, "true")) return (uint16_t)PL_BI_TRUE_0; if (!strcmp(name, "fail")) return (uint16_t)PL_BI_FAIL_0; if (!strcmp(name, "false")) return (uint16_t)PL_BI_FALSE_0; if (!strcmp(name, "halt")) return (uint16_t)PL_BI_HALT_0; if (!strcmp(name, "!")) return (uint16_t)PL_BI_CUT_0; if (!strcmp(name, "repeat")) return (uint16_t)PL_BI_REPEAT_0; if (!strcmp(name, "nl")) return (uint16_t)PL_BI_NL_0; if (!strcmp(name, "flush_output")) return (uint16_t)PL_BI_FLUSH_OUTPUT_0; return (uint16_t)PL_BI_NONE; } if (arity == 1) { if (!strcmp(name, "\\+")) return (uint16_t)PL_BI_NOT_1; if (!strcmp(name, "$drop_barrier")) return (uint16_t)PL_BI_DROP_BARRIER_1; if (!strcmp(name, "$drop_exc_barrier")) return (uint16_t)PL_BI_DROP_EXC_BARRIER_1; return (uint16_t)PL_BI_NONE; } if (arity == 2) { if (!strcmp(name, "$if_barrier")) return (uint16_t)PL_BI_IF_BARRIER_2; if (!strcmp(name, "->")) return (uint16_t)PL_BI_ARROW_2; if (!strcmp(name, ",")) return (uint16_t)PL_BI_COMMA_2; if (!strcmp(name, ";")) return (uint16_t)PL_BI_SEMI_2; if (!strcmp(name, "=")) return (uint16_t)PL_BI_UNIFY_2; if (!strcmp(name, "\\=")) return (uint16_t)PL_BI_NOT_UNIFY_2; if (!strcmp(name, "==")) return (uint16_t)PL_BI_IDENTICAL_2; if (!strcmp(name, "\\==")) return (uint16_t)PL_BI_NOT_IDENTICAL_2; if (!strcmp(name, "=@=")) return (uint16_t)PL_BI_VARIANT_2; if (!strcmp(name, "\\=@=")) return (uint16_t)PL_BI_NOT_VARIANT_2; if (!strcmp(name, "@<")) return (uint16_t)PL_BI_TERM_LT_2; if (!strcmp(name, "@=<")) return (uint16_t)PL_BI_TERM_LTE_2; if (!strcmp(name, "@>")) return (uint16_t)PL_BI_TERM_GT_2; if (!strcmp(name, "@>=")) return (uint16_t)PL_BI_TERM_GTE_2; if (!strcmp(name, "is")) return (uint16_t)PL_BI_IS_2; if (!strcmp(name, "=:=")) return (uint16_t)PL_BI_NUM_EQ_2; if (!strcmp(name, "=\\=")) return (uint16_t)PL_BI_NUM_NE_2; if (!strcmp(name, "<")) return (uint16_t)PL_BI_NUM_LT_2; if (!strcmp(name, "=<")) return (uint16_t)PL_BI_NUM_LTE_2; if (!strcmp(name, ">")) return (uint16_t)PL_BI_NUM_GT_2; if (!strcmp(name, ">=")) return (uint16_t)PL_BI_NUM_GTE_2; return (uint16_t)PL_BI_NONE; } return (uint16_t)PL_BI_NONE; } static uint16_t arith_id_from_name_arity(const CHR *name, ULO arity) { if (!name) { return (uint16_t)PL_ARITH_NONE; } if (arity == 0) { if (!strcmp(name, "pi")) return (uint16_t)PL_ARITH_PI_0; if (!strcmp(name, "e")) return (uint16_t)PL_ARITH_E_0; if (!strcmp(name, "epsilon")) return (uint16_t)PL_ARITH_EPSILON_0; return (uint16_t)PL_ARITH_NONE; } if (arity == 1) { if (!strcmp(name, "+")) return (uint16_t)PL_ARITH_ADD_1; if (!strcmp(name, "-")) return (uint16_t)PL_ARITH_SUB_1; if (!strcmp(name, "abs")) return (uint16_t)PL_ARITH_ABS_1; if (!strcmp(name, "sign")) return (uint16_t)PL_ARITH_SIGN_1; if (!strcmp(name, "floor")) return (uint16_t)PL_ARITH_FLOOR_1; if (!strcmp(name, "ceiling")) return (uint16_t)PL_ARITH_CEILING_1; if (!strcmp(name, "truncate")) return (uint16_t)PL_ARITH_TRUNCATE_1; if (!strcmp(name, "round")) return (uint16_t)PL_ARITH_ROUND_1; if (!strcmp(name, "float_integer_part")) return (uint16_t)PL_ARITH_FLOAT_INTEGER_PART_1; if (!strcmp(name, "float_fractional_part")) return (uint16_t)PL_ARITH_FLOAT_FRACTIONAL_PART_1; if (!strcmp(name, "float")) return (uint16_t)PL_ARITH_FLOAT_1; if (!strcmp(name, "\\")) return (uint16_t)PL_ARITH_BNOT_1; if (!strcmp(name, "sin")) return (uint16_t)PL_ARITH_SIN_1; if (!strcmp(name, "cos")) return (uint16_t)PL_ARITH_COS_1; if (!strcmp(name, "tan")) return (uint16_t)PL_ARITH_TAN_1; if (!strcmp(name, "asin")) return (uint16_t)PL_ARITH_ASIN_1; if (!strcmp(name, "acos")) return (uint16_t)PL_ARITH_ACOS_1; if (!strcmp(name, "atan")) return (uint16_t)PL_ARITH_ATAN_1; if (!strcmp(name, "sqrt")) return (uint16_t)PL_ARITH_SQRT_1; if (!strcmp(name, "log")) return (uint16_t)PL_ARITH_LOG_1; if (!strcmp(name, "exp")) return (uint16_t)PL_ARITH_EXP_1; return (uint16_t)PL_ARITH_NONE; } if (arity == 2) { if (!strcmp(name, "+")) return (uint16_t)PL_ARITH_ADD_2; if (!strcmp(name, "-")) return (uint16_t)PL_ARITH_SUB_2; if (!strcmp(name, "*")) return (uint16_t)PL_ARITH_MUL_2; if (!strcmp(name, "/")) return (uint16_t)PL_ARITH_DIV_2; if (!strcmp(name, "//")) return (uint16_t)PL_ARITH_INTDIV_2; if (!strcmp(name, "rem")) return (uint16_t)PL_ARITH_REM_2; if (!strcmp(name, "div")) return (uint16_t)PL_ARITH_DIV_2_FLOOR; if (!strcmp(name, "mod")) return (uint16_t)PL_ARITH_MOD_2; if (!strcmp(name, "min")) return (uint16_t)PL_ARITH_MIN_2; if (!strcmp(name, "max")) return (uint16_t)PL_ARITH_MAX_2; if (!strcmp(name, "/\\")) return (uint16_t)PL_ARITH_BAND_2; if (!strcmp(name, "\\/")) return (uint16_t)PL_ARITH_BOR_2; if (!strcmp(name, "xor")) return (uint16_t)PL_ARITH_BXOR_2; if (!strcmp(name, "<<")) return (uint16_t)PL_ARITH_SHL_2; if (!strcmp(name, ">>")) return (uint16_t)PL_ARITH_SHR_2; if (!strcmp(name, "**")) return (uint16_t)PL_ARITH_POWF_2; if (!strcmp(name, "^")) return (uint16_t)PL_ARITH_POWI_2; if (!strcmp(name, "atan2")) return (uint16_t)PL_ARITH_ATAN2_2; return (uint16_t)PL_ARITH_NONE; } return (uint16_t)PL_ARITH_NONE; } /* --- SUBSECTION 05.4: Program/Clause Structures -------------------------- */ // Program database structures for predicates, clauses, and flags. // pl_program tracks facts/clauses, dynamic/tabled predicates, op overrides, and flags like double_quotes and engine mode. typedef struct { ULO fact_count; ULO fact_cap; pl_term **facts; // 1-based indexing ULO clause_count; ULO clause_cap; struct pl_clause **clauses; // 1-based ULO dyn_pred_count; ULO dyn_pred_cap; pl_dyn_pred *dyn_preds; // 1-based // Flowlog extensions (tabling): predicates declared via `:- table/1`. ULO tabled_pred_count; ULO tabled_pred_cap; pl_dyn_pred *tabled_preds; // 1-based // ISO-ish: initialization goals declared via `:- initialization/1`. ULO init_goal_count; ULO init_goal_cap; pl_init_goal **init_goals; // 1-based pl_op_overrides *op_overrides; pl_unknown_mode flag_unknown; // ISO prolog_flag unknown (error|warning|fail) bool flag_char_conversion; // ISO prolog_flag char_conversion (on/off) unsigned char char_conv_table[256]; bool flag_character_escapes; // ISO prolog_flag character_escapes (true/false) bool flag_occurs_check; // ISO prolog_flag occurs_check (true/false) bool flag_debug; // ISO prolog_flag debug (on/off) bool flag_trace; // Prolog trace/0 (Byrd-box style ports; non-interactive) bool flag_itrace; // Flowlog extension: itrace/0 (C/internal trace logging) bool flag_itrace_watermark; // Flowlog extension: itrace watermark mode (only emit on new C-stack peaks) pl_double_quotes_mode flag_double_quotes; // prolog_flag double_quotes (atom|codes|chars) // Flowlog extension (engine selection). pl_engine_mode flag_engine; // flowlog_engine (interp|wam|wamvm) // Application argv exposed as `current_prolog_flag(argv, ArgvList)`. ULO flag_argv_count; CHR **flag_argv; ULO flag_argv_default_count; CHR **flag_argv_default; ULO flag_argv_src_count; ULO flag_argv_src_cap; pl_program_argv_src *flag_argv_srcs; // Internal: when true, the WAM-lite engine is disabled for this program // because it uses features/patterns that are not yet supported by the // WAM-lite execution path. bool wam_requires_interp; // Flowlog extensions (parallel execution controls). bool flag_parallel_or; // flowlog_parallel_or (on/off) pl_or_order_mode flag_parallel_or_order; // flowlog_parallel_or_order (ordered/unordered) bool flag_parallel_and; // flowlog_parallel_and (on/off) SLO flag_parallel_max_depth; // flowlog_parallel_max_depth (integer) SLO flag_parallel_or_nesting; // flowlog_parallel_or_nesting (integer; 0=top-level only) // Indexed predicate dispatch (predicate + first-argument). // // `clause_epoch` increments on any database change (assert/retract/abolish). // `index_epoch` tracks which epoch the predicate index reflects. atomic_ulong clause_epoch; atomic_ulong index_epoch; // AND-par "flow analysis" metadata epoch (conservative: user predicates proven // pure and semidet/det can be scheduled as AND-par jobs). atomic_ulong and_safe_epoch; atomic_uint db_readers; atomic_int db_writer; pl_pred_index *pred_index; // Allocation snapshot captured by `pl_parse_program/1` (persistent program objects). // When set, it owns (and can free) the entire program allocation graph. pl_temp_snapshot *alloc_snapshot; } pl_program; struct pl_init_goal { pl_term *goal; const pl_scope *scope; ULO var_count; CHR **var_names; // var_id is index into this array const CHR *src_name; ULO src_line; // 1-based within the loaded file, 0 when unknown ULO src_col; // 1-based within the loaded file, 0 when unknown }; struct pl_program_argv_src { CHR *src_name; ULO argc; CHR **argv; }; struct pl_dyn_pred { CHR *name; ULO arity; }; typedef struct pl_clause { pl_term *head; ULO body_count; pl_term **body; // 1-based const pl_scope *scope; pl_env *env; // optional initial bindings for clause vars (rational trees, asserted bindings) const CHR *src_name; // source file name when loaded from a file, NULL when unknown/dynamic ULO src_line; // 1-based, 0 when unknown ULO src_col; // 1-based, 0 when unknown // Precomputed template sizing for fast standardize-apart instantiation (single arena alloc per clause attempt). ULO tpl_nodes; // total term nodes in head+body(+initial env values) ULO tpl_args; // total struct argument slots across head+body(+initial env values) ULO var_count; // number of vars in the clause scope (max var_id + 1) } pl_clause; typedef struct pl_arg_index pl_arg_index; typedef enum { PL_FAI_NONE = 0, PL_FAI_ATOM, PL_FAI_INT, PL_FAI_FLOAT, PL_FAI_FUNCTOR, } pl_first_arg_index_kind; typedef struct { pl_first_arg_index_kind kind; union { const CHR *atom_name; SLO int_value; double float_value; struct { const CHR *functor; ULO arity; } functor; } v; } pl_first_key; typedef struct { pl_first_key key; uint64_t hash; ULO ord_count; ULO ord_cap; ULO *ords; // clause ordinals into pl_pred_index_entry::clauses (0-based) // Optional deeper indexing for compound/list arguments: index on the first sub-argument (arg0) within this functor bucket. // Allocated lazily when needed; NULL otherwise. pl_arg_index *deep0; } pl_first_bucket; struct pl_arg_index { // Clauses whose argument at this position is a variable (always matches). ULO var_count; ULO var_cap; ULO *var_ords; // clause ordinals into pl_pred_index_entry::clauses (0-based) // Clauses whose argument at this position has a non-var top-level key. pl_first_bucket *buckets; ULO bucket_count; ULO bucket_cap; // Open-addressed hash table of bucket indices (+1); 0 means empty. ULO *bucket_slots; ULO bucket_slot_cap; // power-of-two slot count }; typedef struct { const CHR *name; ULO arity; const pl_clause **clauses; // 0-based list in clause order ULO clause_count; ULO clause_cap; // Multi-arg indexing (one index per argument position), only for arity>0 predicates. pl_arg_index *args; ULO arg_count; // == arity when allocated // Conservative AND-par analysis result (1 means "safe to run as AND-par job": // pure + semidet/det, in all modes). unsigned char and_safe; } pl_pred_index_entry; struct pl_pred_index { pl_pred_index_entry *preds; ULO pred_count; ULO pred_cap; // Open-addressed hash table of predicate indices (+1); 0 means empty. ULO *pred_slots; ULO pred_slot_cap; // power-of-two slot count }; typedef struct { pl_term *term; const pl_scope *scope; ULO var_count; CHR **var_names; // var_id is index into this array ULO goal_count; pl_term **goals; // 1-based externally, but stored 0-based here } pl_query; typedef struct { const pl_scope *scope; ULO var_id; pl_term *value; } pl_binding; typedef struct { const pl_scope *scope; // NULL means empty ULO var_id; pl_term *value; } pl_env_map_entry; enum { FLOWLOG_ENV_LOCAL_BINDINGS = 8, FLOWLOG_ENV_MAP_MIN_BINDINGS = 8, }; struct pl_env { const struct pl_env *parent; // Scope introduced at this environment frame (fresh clause instantiation). // If we are looking up a variable belonging to this scope, there is no need // to scan further ancestors: older frames cannot contain bindings for a // scope that did not yet exist. const pl_scope *intro_scope; ULO count; ULO cap; pl_binding *items; pl_binding local_items[FLOWLOG_ENV_LOCAL_BINDINGS]; ULO map_cap; pl_env_map_entry *map; }; typedef struct { SLO *descrs; size_t descr_count; size_t descr_cap; void **pool_ptrs; // fallback allocations via reallocpool() size_t pool_count; size_t pool_cap; // Process-local allocations (malloc/free) used for query-temporary objects. void **malloc_ptrs; size_t malloc_count; size_t malloc_cap; // Fast bump allocator for query-temporary local allocations (when enabled via // g_pool_local_alloc). Individual allocations are not tracked; instead, the // backing chunks are tracked via `malloc_ptrs` so they can be released at // choicepoint rollback (newer chunks) or at query end. unsigned char *arena_cur; size_t arena_cur_size; size_t arena_off; } pl_temp_alloc; typedef struct { size_t descr_count; size_t pool_count; size_t malloc_count; unsigned char *arena_cur; size_t arena_cur_size; size_t arena_off; } pl_temp_mark; typedef struct pl_temp_snapshot { SLO self_descr; // descriptor for this snapshot struct SLO descrs_descr; // descriptor for `descrs` array block size_t descr_count; SLO *descrs; // asyncheap descriptors to free SLO pool_ptrs_descr; // descriptor for `pool_ptrs` array block size_t pool_count; void **pool_ptrs; // pointers to freepool() // Process-local allocations captured by the snapshot. // These pointers are only valid within the originating process. SLO malloc_ptrs_descr; // descriptor for `malloc_ptrs` array block (0 when heap-allocated) size_t malloc_count; void **malloc_ptrs; // pointers to free() } pl_temp_snapshot; /* ============================================================================ * SECTION 06: Runtime Globals & Diagnostics * TLS flags, per-query state, and tracing diagnostics. * ============================================================================ */ /* --- SUBSECTION 06.1: Runtime Globals ------------------------------------ */ // TLS/global runtime state shared by interpreter and WAM/WAMVM. // Tracks g_temp_alloc, g_engine_active, g_stdio_capture, inference limits, tabling state, and parallel budgets. static FLOWLOG_TLS pl_temp_alloc *g_temp_alloc = NULL; // When true, `pool_alloc` prefers process-local allocations (reallocpool/freepool) // for query-temporary memory. This avoids shared-memory allocator contention for // top-level OR-par jobs where intermediate term/env pointers never need to cross // instruction boundaries. static FLOWLOG_TLS bool g_pool_local_alloc = false; static FLOWLOG_TLS pl_sbuf *g_stdio_capture = NULL; // When true, `flush_output/[0,1]` may drain captured `user_output` to the real // underlying stream and clear the capture buffer, enabling streaming output for // long-running queries that would otherwise only print at query end. // // This is intentionally disabled in OR/AND-par worker contexts to preserve // ISO-visible ordering (captured output is merged deterministically instead). static FLOWLOG_TLS bool g_stdio_capture_drain_ok = false; static FLOWLOG_TLS bool g_unify_occurs_check = false; static FLOWLOG_TLS pl_engine_mode g_engine_active = PL_ENGINE_INTERP; static FLOWLOG_TLS bool g_halt_requested = false; static FLOWLOG_TLS SLO g_halt_code = 0; static FLOWLOG_TLS const atomic_int *g_cancel_flag = NULL; // Optional per-query cancel flag used by the interactive REPL. static atomic_uintptr_t g_query_cancel_ptr = 0; // True when the REPL is streaming solutions (enables OR-par solution spans). static atomic_int g_solution_stream_active = 0; // Optional per-thread inference limit (used by quad testing and future timeout/limit features). // When `g_inference_limit` is non-zero, the solvers periodically increment `g_inference_count` // and throw the exception `inference_limit_exceeded` once the limit is exceeded. static FLOWLOG_TLS uint64_t g_inference_limit = 0; // 0 => unlimited static FLOWLOG_TLS uint64_t g_inference_count = 0; static FLOWLOG_TLS pl_table_state *g_table_state = NULL; static FLOWLOG_TLS atomic_int *g_par_budget = NULL; static FLOWLOG_TLS uint64_t g_last_tc_cp_mask = 0; static FLOWLOG_TLS ULO g_last_tc_worker_count = 0; static FLOWLOG_TLS int g_last_tc_start_ok = 0; static FLOWLOG_TLS UCH g_last_tc_start_err_code = 0; static FLOWLOG_TLS CHR g_last_tc_start_err_text[256] = {0}; static int g_halt_barrier = 0; typedef struct pl_solution_stream pl_solution_stream; typedef struct pl_solution_capture pl_solution_capture; typedef struct pl_solution_span pl_solution_span; static FLOWLOG_TLS pl_solution_stream *g_solution_stream = NULL; static FLOWLOG_TLS pl_solution_capture *g_solution_capture = NULL; // Optional path of the currently loaded program file (CLI/REPL). // NULL means the interactive [user] program. static const CHR *g_loaded_program_path = NULL; // Current program being executed (set while running queries; used for SIGINFO // status reporting even when not tracing). static FLOWLOG_TLS const pl_program *g_current_prog = NULL; // Approximate C stack usage tracking (per-thread). // // This is best-effort: the base marker is captured once per thread (ideally at // thread entry) and we track the maximum observed distance from that marker // during a query. Used for SIGINFO/debugging output. static FLOWLOG_TLS uintptr_t g_cstack_base = 0; static FLOWLOG_TLS size_t g_cstack_max = 0; static FLOWLOG_TLS ULO g_cstack_max_trace_depth = 0; // Optional C stack soft limit (in bytes). When non-zero, Flowlog throws an // ISO-style resource_error(stack) exception before the process hits a hard // SIGSEGV stack overflow. static size_t g_cstack_limit_bytes = 0; static FLOWLOG_TLS bool g_cstack_limit_tripped = false; // Optional itrace mode: only print internal trace lines when C stack usage hits // a new peak ("watermark"). static FLOWLOG_TLS size_t g_itrace_watermark_max = 0; /* --- SUBSECTION 06.2: C-Stack/Trace Diagnostics -------------------------- */ // C-stack tracking and trace-frame capture for diagnostics. // flowlog_cstack_init_once() and flowlog_cstack_used_bytes() support SIGINFO reporting and itrace watermarking. #ifndef FLOWLOG_CSTACK_PEAK_TOP_FRAMES #define FLOWLOG_CSTACK_PEAK_TOP_FRAMES 8 #endif typedef struct { const CHR *name; ULO arity; ULO src_line; ULO src_col; } pl_trace_brief_frame; typedef struct { size_t used_bytes; ULO depth; bool overflow_valid; pl_trace_brief_frame overflow; unsigned top_count; pl_trace_brief_frame top[FLOWLOG_CSTACK_PEAK_TOP_FRAMES]; } pl_cstack_peak; static FLOWLOG_TLS pl_cstack_peak g_cstack_peak = {0}; static inline void flowlog_cstack_init_once(void) { if (g_cstack_base) { return; } unsigned char marker = 0; g_cstack_base = (uintptr_t)(const void *)▮ g_cstack_max = 0; g_cstack_max_trace_depth = 0; } static inline size_t flowlog_cstack_used_bytes(void) { if (!g_cstack_base) { return 0; } unsigned char marker = 0; const uintptr_t cur = (uintptr_t)(const void *)▮ const uintptr_t base = g_cstack_base; return (size_t)((cur > base) ? (cur - base) : (base - cur)); } static void flowlog_cstack_note(ULO trace_depth); typedef struct { const CHR *name; ULO arity; ULO src_line; ULO src_col; const pl_term *goal; } pl_trace_frame; static FLOWLOG_TLS pl_trace_frame *g_trace_frames = NULL; static FLOWLOG_TLS ULO g_trace_frames_cap = 0; static FLOWLOG_TLS ULO g_trace_depth = 0; static FLOWLOG_TLS const pl_clause *g_trace_clause = NULL; static FLOWLOG_TLS const pl_clause *g_argv_clause = NULL; static FLOWLOG_TLS long g_itrace_last_depth = -1; static FLOWLOG_TLS bool g_trace_overflow = false; static FLOWLOG_TLS ULO g_trace_overflow_depth = 0; static FLOWLOG_TLS pl_trace_frame g_trace_overflow_frame = {0}; static inline const pl_trace_frame *trace_frame_get(ULO depth) { if (!g_trace_frames || (depth >= g_trace_frames_cap)) { return NULL; } return &g_trace_frames[depth]; } static inline pl_trace_frame *trace_frame_get_mut(ULO depth) { if (!g_trace_frames || (depth >= g_trace_frames_cap)) { return NULL; } return &g_trace_frames[depth]; } static inline long trace_storage_top_for_depth(ULO depth) { if (!g_trace_frames || !g_trace_frames_cap) { return -1; } if (depth >= g_trace_frames_cap) { return (long)(g_trace_frames_cap - 1); } return (long)depth; } static inline const pl_clause *flowlog_argv_clause_push(const pl_clause *cl) { const pl_clause *saved = g_argv_clause; g_argv_clause = cl; return saved; } static inline void flowlog_argv_clause_pop(const pl_clause *saved) { g_argv_clause = saved; } static bool trace_frame_ensure_slot(ULO depth) { if (FLOWLOG_DEPTH_LIMIT_REACHED(depth, FLOWLOG_TRACE_MAX_DEPTH)) { return false; } if (g_trace_frames && (depth < g_trace_frames_cap)) { return true; } const ULO need = depth + 1; if (need <= depth) { return false; } ULO new_cap = g_trace_frames_cap ? g_trace_frames_cap : 64u; while (new_cap < need) { if (new_cap > (ULO)(SIZE_MAX / (sizeof(pl_trace_frame) * 2u))) { new_cap = need; break; } new_cap *= 2u; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(new_cap, FLOWLOG_TRACE_MAX_DEPTH)) { new_cap = (ULO)FLOWLOG_TRACE_MAX_DEPTH; } if (new_cap < need || (new_cap > (ULO)(SIZE_MAX / sizeof(pl_trace_frame)))) { return false; } const size_t bytes = (size_t)new_cap * sizeof(pl_trace_frame); pl_trace_frame *new_frames = (pl_trace_frame *)malloc(bytes); if (!new_frames) { return false; } memset(new_frames, 0, bytes); if (g_trace_frames && g_trace_frames_cap) { memcpy(new_frames, g_trace_frames, (size_t)g_trace_frames_cap * sizeof(pl_trace_frame)); } pl_trace_frame *old = g_trace_frames; g_trace_frames = new_frames; g_trace_frames_cap = new_cap; if (old) { free(old); } return true; } /* --- SUBSECTION 06.3: SIGSEGV Trace Support ------------------------------ */ // SIGSEGV-safe formatting helpers for crash diagnostics. // flowlog_sig_strnlen(), flowlog_sig_write_mem(), flowlog_sig_write_cstr(), and flowlog_sig_write_ulong() write without malloc. #if defined(SIGSEGV) static atomic_bool g_sigsegv_trace_enabled = ATOMIC_VAR_INIT(false); static pthread_once_t g_sigsegv_trace_once = PTHREAD_ONCE_INIT; static FLOWLOG_TLS void *g_sigsegv_altstack_mem = NULL; static pthread_key_t g_sigsegv_altstack_key; static bool g_sigsegv_altstack_key_ok = false; static inline size_t flowlog_sig_strnlen(const char *s, size_t max) { if (!s || !max) { return 0; } size_t n = 0; while (n < max && s[n]) { n++; } return n; } static void flowlog_sig_write_mem(int fd, const char *s, size_t n) { if (fd < 0 || !s || !n) { return; } while (n) { const ssize_t w = write(fd, s, n); if (w > 0) { s += (size_t)w; n -= (size_t)w; continue; } if (w < 0 && errno == EINTR) { continue; } break; } } static void flowlog_sig_write_cstr(int fd, const char *s) { const size_t n = flowlog_sig_strnlen(s, 4096); flowlog_sig_write_mem(fd, s, n); } static void flowlog_sig_write_ulong(int fd, unsigned long v) { char buf[32]; size_t n = 0; if (v == 0) { buf[n++] = '0'; } else { while (v && n < sizeof(buf)) { buf[n++] = (char)('0' + (v % 10)); v /= 10; } } for (size_t i = 0; i < n / 2; i++) { const char tmp = buf[i]; buf[i] = buf[n - 1 - i]; buf[n - 1 - i] = tmp; } flowlog_sig_write_mem(fd, buf, n); } static void flowlog_sig_write_frame(int fd, const pl_trace_frame *f, ULO depth) { if (!f || !f->name) { return; } flowlog_sig_write_cstr(fd, " "); flowlog_sig_write_cstr(fd, f->name); flowlog_sig_write_cstr(fd, "/"); flowlog_sig_write_ulong(fd, (unsigned long)f->arity); if (f->src_line) { flowlog_sig_write_cstr(fd, " at "); flowlog_sig_write_ulong(fd, (unsigned long)f->src_line); flowlog_sig_write_cstr(fd, ":"); flowlog_sig_write_ulong(fd, (unsigned long)f->src_col); } flowlog_sig_write_cstr(fd, " (depth="); flowlog_sig_write_ulong(fd, (unsigned long)depth); flowlog_sig_write_cstr(fd, ")\n"); } static void flowlog_sigsegv_trace_handler(int signum, siginfo_t *info, void *uctx) { (void)info; (void)uctx; flowlog_sig_write_cstr(STDERR_FILENO, "\nflowlog: fatal SIGSEGV (possible stack overflow)\n"); const ULO depth_real = g_trace_depth; flowlog_sig_write_cstr(STDERR_FILENO, " trace_depth="); flowlog_sig_write_ulong(STDERR_FILENO, (unsigned long)depth_real); flowlog_sig_write_cstr(STDERR_FILENO, "\n"); flowlog_sig_write_cstr(STDERR_FILENO, " c_stack_peak_max="); flowlog_sig_write_ulong(STDERR_FILENO, (unsigned long)g_cstack_max); flowlog_sig_write_cstr(STDERR_FILENO, " c_stack_peak_depth="); flowlog_sig_write_ulong(STDERR_FILENO, (unsigned long)g_cstack_max_trace_depth); flowlog_sig_write_cstr(STDERR_FILENO, "\n"); flowlog_sig_write_cstr(STDERR_FILENO, " stack_top:\n"); if (g_trace_overflow && g_trace_overflow_frame.name && (g_trace_overflow_depth == depth_real)) { flowlog_sig_write_frame(STDERR_FILENO, &g_trace_overflow_frame, depth_real); } const long top = trace_storage_top_for_depth(depth_real); unsigned shown = 0; for (long d = top; d >= 0 && shown < 5; d--) { const pl_trace_frame *f = trace_frame_get((ULO)d); if (!f->name) { continue; } flowlog_sig_write_frame(STDERR_FILENO, f, (ULO)d); shown++; } _Exit(128 + signum); } static void flowlog_sigsegv_altstack_destructor(void *ptr) { if (!ptr) { return; } #if defined(SS_DISABLE) stack_t ss; memset(&ss, 0, sizeof(ss)); ss.ss_flags = SS_DISABLE; (void)sigaltstack(&ss, NULL); #endif free(ptr); } static void flowlog_install_sigsegv_trace_handler_once(void) { if (pthread_key_create(&g_sigsegv_altstack_key, flowlog_sigsegv_altstack_destructor) == 0) { g_sigsegv_altstack_key_ok = true; } struct sigaction sa; memset(&sa, 0, sizeof(sa)); sa.sa_sigaction = flowlog_sigsegv_trace_handler; (void)sigemptyset(&sa.sa_mask); sa.sa_flags = SA_SIGINFO | SA_ONSTACK; (void)sigaction(SIGSEGV, &sa, NULL); } static void flowlog_install_sigsegv_trace_handler(bool enabled) { if (!enabled) { return; } atomic_store_explicit(&g_sigsegv_trace_enabled, true, memory_order_relaxed); (void)pthread_once(&g_sigsegv_trace_once, flowlog_install_sigsegv_trace_handler_once); if (g_sigsegv_altstack_mem) { return; } size_t sz = (size_t)SIGSTKSZ * 4; if (sz < 65536) { sz = 65536; } void *mem = malloc(sz); if (!mem) { return; } stack_t ss; memset(&ss, 0, sizeof(ss)); ss.ss_sp = mem; ss.ss_size = sz; ss.ss_flags = 0; if (sigaltstack(&ss, NULL) != 0) { free(mem); return; } g_sigsegv_altstack_mem = mem; if (g_sigsegv_altstack_key_ok) { (void)pthread_setspecific(g_sigsegv_altstack_key, mem); } } #endif static void flowlog_cstack_note(ULO trace_depth) { const size_t used = flowlog_cstack_used_bytes(); if (used <= g_cstack_max) { return; } g_cstack_max = used; g_cstack_max_trace_depth = trace_depth; g_cstack_peak.used_bytes = used; g_cstack_peak.depth = trace_depth; g_cstack_peak.top_count = 0; g_cstack_peak.overflow_valid = false; memset(&g_cstack_peak.overflow, 0, sizeof(g_cstack_peak.overflow)); if (g_trace_overflow && g_trace_overflow_frame.name && (g_trace_overflow_depth == trace_depth)) { g_cstack_peak.overflow_valid = true; g_cstack_peak.overflow = (pl_trace_brief_frame){ .name = g_trace_overflow_frame.name, .arity = g_trace_overflow_frame.arity, .src_line = g_trace_overflow_frame.src_line, .src_col = g_trace_overflow_frame.src_col, }; } const long idx = trace_storage_top_for_depth(trace_depth); for (long d = idx; d >= 0 && g_cstack_peak.top_count < (unsigned)FLOWLOG_CSTACK_PEAK_TOP_FRAMES; d--) { const pl_trace_frame *f = trace_frame_get((ULO)d); if (!f->name) { continue; } g_cstack_peak.top[g_cstack_peak.top_count++] = (pl_trace_brief_frame){ .name = f->name, .arity = f->arity, .src_line = f->src_line, .src_col = f->src_col, }; } } static void trace_reset(void); static void flowlog_trace_diag_reset_tls(void) { flowlog_cstack_init_once(); g_cstack_max = 0; g_cstack_max_trace_depth = 0; g_cstack_limit_tripped = false; g_itrace_watermark_max = 0; memset(&g_cstack_peak, 0, sizeof(g_cstack_peak)); trace_reset(); } static bool trace_goal_name_hidden_prolog(const CHR *name); static void trace_emit_prolog_term(char prefix, ULO depth, const char *port, const pl_term *goal, const pl_env *env, const pl_clause *cl); static void trace_emit_prolog_goal(char prefix, ULO depth, const char *port, const pl_term *goal, const pl_clause *cl); // Internal OR-par uses pthread workers; avoid recursive OR-par spawning from // within OR-par chunk execution (can explode thread counts and deadlock some // allocator/scheduler paths). This guard is per-thread. static FLOWLOG_TLS int g_orpar_level = 0; // True when running in a pthread OR-par worker. In this mode, prefer // process-local allocations for per-chunk outputs to keep worker output buffers // thread-local (merged and freed by the committer thread). static FLOWLOG_TLS bool g_orpar_thread_worker = false; // When collecting solutions via an `on_solution` callback (findall/bagof/etc), // the solver normally disables per-choicepoint temp allocator release to avoid // invalidating collector pointers. Some collectors deep-copy results into their // own temp allocation graph, so it is safe (and much faster) to allow temp // releases while search backtracks. static FLOWLOG_TLS bool g_on_solution_safe_temp_release = false; #ifndef POSIXMTHREAD_NOT_SUPPORTED // `findall/3`, `bagof/3`, etc. use an `on_solution` callback to collect terms. // In unordered OR-par, multiple workers may complete concurrently; serialize // callback execution so collectors remain thread-safe. static pthread_mutex_t g_on_solution_mu = PTHREAD_MUTEX_INITIALIZER; static inline void on_solution_lock(void) { (void)pthread_mutex_lock(&g_on_solution_mu); } static inline void on_solution_unlock(void) { (void)pthread_mutex_unlock(&g_on_solution_mu); } #else static inline void on_solution_lock(void) {} static inline void on_solution_unlock(void) {} #endif static void flowlog_siginfo_report(void); static inline bool flowlog_cancelled(void) { if (flowlog_siginfo_take()) { flowlog_siginfo_report(); } if (flowlog_interrupted()) { return true; } const atomic_int *qcancel = (const atomic_int *)atomic_load_explicit(&g_query_cancel_ptr, memory_order_relaxed); if (qcancel && (atomic_load_explicit(qcancel, memory_order_relaxed) != 0)) { return true; } return g_cancel_flag && (atomic_load_explicit(g_cancel_flag, memory_order_relaxed) != 0); } static uint64_t flowlog_monotonic_ns(void) { struct timespec ts; if (clock_gettime(CLOCK_MONOTONIC, &ts) != 0) { return 0; } return ((uint64_t)ts.tv_sec * 1000000000ull) + (uint64_t)ts.tv_nsec; } /* --- SUBSECTION 06.4: OR-par Debug Logging ------------------------------- */ // OR-par debug logging helpers. // flowlog_debug_orpar_level(), flowlog_debug_orpar_log_fd(), flowlog_debug_orpar_printf(), and flowlog_debug_orpar_log_stop() manage logging. static int flowlog_debug_orpar_level(void) { // 0 = off, 1 = big choicepoints only, 2 = all OR-par sites. static int cached = -1; if (cached >= 0) { return cached; } const char *e = getenv("FLOWLOG_DEBUG_ORPAR"); if (!e || !*e || !strcmp(e, "0") || !strcmp(e, "off")) { cached = 0; } else if (!strcmp(e, "all") || !strcmp(e, "2")) { cached = 2; } else { cached = 1; } return cached; } static int flowlog_debug_orpar_log_fd(void) { // -2 = uninitialized, -1 = stderr, >=0 = open fd. static int cached = -2; if (cached != -2) { return cached; } const char *path = getenv("FLOWLOG_DEBUG_ORPAR_LOG"); if (!path || !*path) { cached = -1; return cached; } const int fd = open(path, O_WRONLY | O_CREAT | O_APPEND, 0644); cached = (fd >= 0) ? fd : -1; return cached; } static void flowlog_debug_orpar_printf(const char *fmt, ...) { if (!fmt) { return; } va_list ap; va_start(ap, fmt); CHR buf[512]; const int n = vsnprintf(buf, sizeof(buf), fmt, ap); va_end(ap); if (n <= 0) { return; } const int fd = flowlog_debug_orpar_log_fd(); if (fd >= 0) { const size_t len = (size_t)n < (sizeof(buf) - 1) ? (size_t)n : (sizeof(buf) - 1); (void)write(fd, buf, len); return; } (void)fwrite(buf, 1, (size_t)n, stderr); (void)fflush(stderr); } static void flowlog_debug_orpar_log_start(const char *pred, ULO arity, ULO alt_count, ULO worker_count, ULO chunk_count, ULO depth, bool stop_at_first) { const int lvl = flowlog_debug_orpar_level(); if (lvl <= 0) { return; } if ((lvl == 1) && (alt_count < (ULO)FLOWLOG_ORPAR_BIG_ALT_THRESHOLD)) { return; } flowlog_debug_orpar_printf("flowlog: ORPAR start %s/%lu alt=%lu workers=%lu chunks=%lu depth=%lu stop_at_first=%s\n", pred ? pred : "?", (unsigned long)arity, (unsigned long)alt_count, (unsigned long)worker_count, (unsigned long)chunk_count, (unsigned long)depth, stop_at_first ? "true" : "false"); } static void flowlog_debug_orpar_log_stop(const char *pred, ULO arity, ULO alt_count, uint64_t elapsed_ns, bool stopped, bool cancelled) { const int lvl = flowlog_debug_orpar_level(); if (lvl <= 0) { return; } if ((lvl == 1) && (alt_count < (ULO)FLOWLOG_ORPAR_BIG_ALT_THRESHOLD)) { return; } const double ms = elapsed_ns ? ((double)elapsed_ns / 1000000.0) : 0.0; flowlog_debug_orpar_printf("flowlog: ORPAR stop %s/%lu elapsed_ms=%.3f stopped=%s cancel=%s\n", pred ? pred : "?", (unsigned long)arity, ms, stopped ? "true" : "false", cancelled ? "true" : "false"); } /* ============================================================================ * SECTION 07: Parallel Runtime State & Thread Pool * shared parallel state, worker pool, and budget accounting. * ============================================================================ */ /* --- SUBSECTION 07.1: Forward Declarations ------------------------------- */ // Forward declarations to break ordering cycles. // Declares temp_alloc_free_all(), shm_alloc(), and shm_free_descr() before pool/allocator code. static void temp_alloc_free_all(pl_temp_alloc *ta, const void *rt_ctrl, const ULO *dbg_dat_ptr); static void shm_free_descr(const void *rt_ctrl, const ULO *dbg_dat_ptr, SLO descr); static void *shm_alloc(const void *rt_ctrl, SLO bytes, const ULO *dbg_dat_ptr, SLO *out_descr); /* --- SUBSECTION 07.2: Pool Tasks & State --------------------------------- */ // Thread-pool task structures and shared parallel state. // pl_pool_task/pl_parallel_state plus flowlog_thread_pool_enabled() and flowlog_pool_local_alloc_enabled() gate features. typedef void (*pl_pool_task_fn)(void *arg, const void *rt_ctrl, const ULO *dbg_dat_ptr); typedef struct pl_pool_task { pl_pool_task_fn fn; void *arg; pl_program *prog; // optional (used for per-task TLS like occurs_check + SIGINFO reporting) const void *rt_ctrl; const ULO *dbg_dat_ptr; struct pl_pool_task *next; } pl_pool_task; typedef struct { int max_threads; atomic_int budget; // max extra threads allowed pl_engine_mode engine_active; // Optional shared inference limit across OR/AND-par worker threads for the // duration of a query (set via $flowlog_inference_limit_shared/1). atomic_uint_fast64_t shared_inference_limit; // 0 => unlimited / disabled atomic_uint_fast64_t shared_inference_count; // Worker pool: reuse threads across OR/AND-par starts within a query. pthread_mutex_t pool_mu; pthread_cond_t pool_cv; pl_pool_task *pool_head; pl_pool_task *pool_tail; pthread_t *pool_threads; int pool_thread_count; bool pool_shutdown; bool pool_started; pthread_mutex_t mu; pl_temp_alloc **adopted; // temp allocators that must survive until query end (e.g. uncaught exceptions) size_t adopted_count; size_t adopted_cap; pl_temp_snapshot **snapshots; // temp snapshots that must survive until query end size_t snapshot_count; size_t snapshot_cap; } pl_parallel_state; static FLOWLOG_TLS pl_parallel_state *g_par_state = NULL; static bool flowlog_thread_pool_enabled(void) { const char *e = getenv("FLOWLOG_THREADPOOL"); if (!e || !*e) { return true; // default on } return strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false"); } static bool flowlog_pool_local_alloc_enabled(void) { const char *local_alloc_env = getenv("FLOWLOG_POOL_LOCAL_ALLOC"); if (local_alloc_env && *local_alloc_env) { // Treat any non-zero, non-"off"/"false" value as enabled. return strcmp(local_alloc_env, "0") && strcmp(local_alloc_env, "off") && strcmp(local_alloc_env, "false"); } // Default: prefer local bump allocations for query-temporary memory. return true; } /* --- SUBSECTION 07.3: Pool Thread Lifecycle ------------------------------ */ // Thread pool lifecycle and snapshot handling. // par_pool_ensure() starts workers, par_pool_enqueue() schedules tasks, and par_state_adopt_snapshot()/par_state_free_all() manage temp snapshots. static void *par_pool_thread_main(void *arg) { pl_parallel_state *st = (pl_parallel_state *)arg; if (!st) { return NULL; } setup_thread_safe_functionality_for_local_thread(); flowlog_cstack_init_once(); #if defined(SIGSEGV) flowlog_install_sigsegv_trace_handler(atomic_load_explicit(&g_sigsegv_trace_enabled, memory_order_relaxed)); #endif g_par_state = st; g_par_budget = &st->budget; g_orpar_thread_worker = true; g_pool_local_alloc = flowlog_pool_local_alloc_enabled(); g_engine_active = st->engine_active; for (;;) { (void)pthread_mutex_lock(&st->pool_mu); while (!st->pool_shutdown && !st->pool_head) { (void)pthread_cond_wait(&st->pool_cv, &st->pool_mu); } if (st->pool_shutdown) { (void)pthread_mutex_unlock(&st->pool_mu); break; } pl_pool_task *t = st->pool_head; st->pool_head = t ? t->next : NULL; if (!st->pool_head) { st->pool_tail = NULL; } (void)pthread_mutex_unlock(&st->pool_mu); if (!t || !t->fn) { continue; } // Reset per-task TLS diagnostics so a previous task doesn't suppress new // reports (notably for c-stack limit and itrace watermark mode). flowlog_trace_diag_reset_tls(); if (t->prog) { g_current_prog = t->prog; g_unify_occurs_check = t->prog->flag_occurs_check; } t->fn(t->arg, t->rt_ctrl, t->dbg_dat_ptr); } cleanup_thread_safe_functionality_for_local_thread(); return NULL; } static bool par_pool_ensure(pl_parallel_state *st, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)rt_ctrl; (void)dbg_dat_ptr; if (!st || !flowlog_thread_pool_enabled()) { return false; } (void)pthread_mutex_lock(&st->mu); if (st->pool_started) { (void)pthread_mutex_unlock(&st->mu); return st->pool_thread_count > 0; } const int want_threads = st->max_threads - 1; if (want_threads <= 0) { (void)pthread_mutex_unlock(&st->mu); return false; } pthread_t *ths = (pthread_t *)calloc((size_t)want_threads, sizeof(*ths)); if (!ths) { (void)pthread_mutex_unlock(&st->mu); return false; } pthread_attr_t attr; bool have_attr = (pthread_attr_init(&attr) == 0); if (have_attr) { size_t stack_sz = flowlog_default_orpar_stack_size_bytes((ULO)want_threads); const char *env = getenv("FLOWLOG_ORPAR_STACK_SIZE"); if (env && *env) { char *end = NULL; unsigned long long v = strtoull(env, &end, 10); if (end && *end == '\0' && v >= (unsigned long long)PTHREAD_STACK_MIN) { stack_sz = (size_t)v; } } if (stack_sz < (size_t)PTHREAD_STACK_MIN) { stack_sz = (size_t)PTHREAD_STACK_MIN; } (void)pthread_attr_setstacksize(&attr, stack_sz); } int created = 0; for (int i = 0; i < want_threads; i++) { const int rc = pthread_create(&ths[i], have_attr ? &attr : NULL, par_pool_thread_main, st); if (rc != 0) { break; } created++; } if (have_attr) { (void)pthread_attr_destroy(&attr); } if (created <= 0) { free(ths); (void)pthread_mutex_unlock(&st->mu); return false; } st->pool_threads = ths; st->pool_thread_count = created; st->pool_started = true; (void)pthread_mutex_unlock(&st->mu); return true; } static void par_pool_enqueue(pl_parallel_state *st, pl_pool_task *t) { if (!st || !t) { return; } (void)pthread_mutex_lock(&st->pool_mu); if (!st->pool_tail) { st->pool_head = t; st->pool_tail = t; } else { st->pool_tail->next = t; st->pool_tail = t; } (void)pthread_cond_signal(&st->pool_cv); (void)pthread_mutex_unlock(&st->pool_mu); } static pl_parallel_state *par_state_create(int max_threads) { if (max_threads < 2) { return NULL; } pl_parallel_state *st = (pl_parallel_state *)calloc(1, sizeof(*st)); if (!st) { return NULL; } st->max_threads = max_threads; atomic_init(&st->budget, max_threads - 1); atomic_init(&st->shared_inference_limit, 0); atomic_init(&st->shared_inference_count, 0); st->engine_active = PL_ENGINE_INTERP; (void)pthread_mutex_init(&st->pool_mu, NULL); (void)pthread_cond_init(&st->pool_cv, NULL); (void)pthread_mutex_init(&st->mu, NULL); return st; } static void par_state_adopt_snapshot(pl_parallel_state *st, pl_temp_snapshot *snap) { if (!st || !snap) { return; } (void)pthread_mutex_lock(&st->mu); if (st->snapshot_count == st->snapshot_cap) { size_t new_cap = st->snapshot_cap ? (st->snapshot_cap * 2) : 16; pl_temp_snapshot **new_items = (pl_temp_snapshot **)realloc(st->snapshots, new_cap * sizeof(pl_temp_snapshot *)); if (new_items) { st->snapshots = new_items; st->snapshot_cap = new_cap; } } if (st->snapshot_count < st->snapshot_cap) { st->snapshots[st->snapshot_count++] = snap; } (void)pthread_mutex_unlock(&st->mu); } static void par_state_free_all(pl_parallel_state *st, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!st) { return; } if (st->pool_started && st->pool_threads && st->pool_thread_count > 0) { (void)pthread_mutex_lock(&st->pool_mu); st->pool_shutdown = true; (void)pthread_cond_broadcast(&st->pool_cv); (void)pthread_mutex_unlock(&st->pool_mu); for (int i = 0; i < st->pool_thread_count; i++) { (void)pthread_join(st->pool_threads[i], NULL); } free(st->pool_threads); st->pool_threads = NULL; st->pool_thread_count = 0; } (void)pthread_mutex_destroy(&st->pool_mu); (void)pthread_cond_destroy(&st->pool_cv); (void)pthread_mutex_lock(&st->mu); for (size_t i = 0; i < st->adopted_count; i++) { pl_temp_alloc *ta = st->adopted[i]; if (!ta) { continue; } temp_alloc_free_all(ta, rt_ctrl, dbg_dat_ptr); free(ta); st->adopted[i] = NULL; } for (size_t i = 0; i < st->snapshot_count; i++) { pl_temp_snapshot *snap = st->snapshots[i]; if (!snap) { continue; } for (size_t j = 0; j < snap->descr_count; j++) { shm_free_descr(rt_ctrl, dbg_dat_ptr, snap->descrs[j]); } for (size_t j = 0; j < snap->pool_count; j++) { freepool(snap->pool_ptrs[j]); } if (snap->descrs_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, snap->descrs_descr); } if (snap->pool_ptrs_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, snap->pool_ptrs_descr); } const SLO self_descr = snap->self_descr; if (self_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, self_descr); } st->snapshots[i] = NULL; } free(st->adopted); st->adopted = NULL; st->adopted_count = 0; st->adopted_cap = 0; free(st->snapshots); st->snapshots = NULL; st->snapshot_count = 0; st->snapshot_cap = 0; (void)pthread_mutex_unlock(&st->mu); (void)pthread_mutex_destroy(&st->mu); free(st); } /* --- SUBSECTION 07.4: Global Budget Helpers ------------------------------ */ // Global parallel budget helpers. // par_global_budget_take_up_to() and par_global_budget_give() throttle worker counts. static int par_global_budget_take_up_to(atomic_int *budget, int want) { if (!budget || want <= 0) { return 0; } int cur = atomic_load(budget); while (cur > 0) { const int take = (cur < want) ? cur : want; if (atomic_compare_exchange_weak(budget, &cur, cur - take)) { return take; } } return 0; } static void par_global_budget_give(atomic_int *budget, int n) { if (!budget || n <= 0) { return; } atomic_fetch_add(budget, n); } /* ============================================================================ * SECTION 08: Streams & I/O State * stream registry, pushback buffers, and stream metadata. * ============================================================================ */ /* --- SUBSECTION 08.1: Stream Structs ------------------------------------- */ // Stream structures and state for IO bookkeeping. // pl_stream holds mode/encoding/pushback/line info; pl_stream_state tracks current streams and ids. typedef struct { bool open; bool readable; bool writable; bool binary; // true => binary_stream, false => text_stream bool repositionable; unsigned char eof_action; // 0=eof_code, 1=error, 2=reset bool bom; CHR *encoding; FILE *fp; CHR *alias; CHR *file_name; CHR *mode; // read|write|append bool eos_past; // true once EOF has been read SLO *pushback; // LIFO, stores -1 or character codes/bytes size_t pushback_count; size_t pushback_cap; ULO line_count; // 1-based line number of next character ULO line_pos; // 1-based column of next character } pl_stream; enum { PL_EOF_ACTION_EOF_CODE = 0, PL_EOF_ACTION_ERROR = 1, PL_EOF_ACTION_RESET = 2, }; typedef struct { pl_stream *items; // indexed by stream id size_t cap; SLO current_input; SLO current_output; SLO next_id; } pl_stream_state; static FLOWLOG_TLS pl_stream_state g_streams = {0}; static pl_term *deref_term(pl_term *t, const pl_env *env); static pl_term *make_int_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, SLO v); static pl_term *make_struct_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *functor, ULO arity); static pl_term *make_nil_rt(const ULO *dbg_dat_ptr); /* --- SUBSECTION 08.2: Stream Registry & Lifecycle ------------------------ */ // Stream registry initialization and lifecycle management. // streams_init()/streams_ensure_capacity() create standard streams; stream_free_pushback()/stream_free_meta() release per-query streams. static void streams_init(const ULO *dbg_dat_ptr) { if (g_streams.items) { return; } g_streams.cap = 16; g_streams.items = (pl_stream *)calloc(g_streams.cap, sizeof(pl_stream)); if (!g_streams.items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } // Reserve standard streams. g_streams.items[0] = (pl_stream){.open = true, .readable = true, .writable = false, .binary = false, .repositionable = false, .eof_action = PL_EOF_ACTION_RESET, .bom = false, .encoding = strdup("UTF-8"), .fp = stdin, .alias = strdup("user_input"), .file_name = strdup("stdin"), .line_count = 1, .line_pos = 1, .mode = strdup("read")}; g_streams.items[1] = (pl_stream){.open = true, .readable = false, .writable = true, .binary = false, .repositionable = false, .eof_action = PL_EOF_ACTION_RESET, .bom = false, .encoding = strdup("UTF-8"), .fp = stdout, .alias = strdup("user_output"), .file_name = strdup("stdout"), .line_count = 1, .line_pos = 1, .mode = strdup("append")}; g_streams.items[2] = (pl_stream){.open = true, .readable = false, .writable = true, .binary = false, .repositionable = false, .eof_action = PL_EOF_ACTION_RESET, .bom = false, .encoding = strdup("UTF-8"), .fp = stderr, .alias = strdup("user_error"), .file_name = strdup("stderr"), .line_count = 1, .line_pos = 1, .mode = strdup("append")}; g_streams.current_input = 0; g_streams.current_output = 1; g_streams.next_id = 4; } static void streams_ensure_capacity(const ULO *dbg_dat_ptr, size_t want) { if (want <= g_streams.cap) { return; } size_t new_cap = g_streams.cap ? g_streams.cap : 16; while (new_cap < want) { new_cap *= 2; } pl_stream *new_items = (pl_stream *)realloc(g_streams.items, new_cap * sizeof(pl_stream)); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memset(new_items + g_streams.cap, 0, (new_cap - g_streams.cap) * sizeof(pl_stream)); g_streams.items = new_items; g_streams.cap = new_cap; } static void stream_free_pushback(pl_stream *s) { if (!s) { return; } free(s->pushback); s->pushback = NULL; s->pushback_count = 0; s->pushback_cap = 0; } static void stream_free_meta(pl_stream *s) { if (!s) { return; } free(s->alias); free(s->file_name); free(s->mode); free(s->encoding); s->alias = NULL; s->file_name = NULL; s->mode = NULL; s->encoding = NULL; } static void stream_pushback_push(pl_stream *s, const ULO *dbg_dat_ptr, SLO v) { if (!s) { return; } if (s->pushback_count == s->pushback_cap) { size_t new_cap = s->pushback_cap ? (s->pushback_cap * 2) : 8; SLO *new_items = (SLO *)realloc(s->pushback, new_cap * sizeof(SLO)); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } s->pushback = new_items; s->pushback_cap = new_cap; } s->eos_past = false; s->pushback[s->pushback_count++] = v; } static void streams_reset_for_query(const ULO *dbg_dat_ptr) { streams_init(dbg_dat_ptr); // Clear any buffered input across queries (including standard streams). for (size_t i = 0; i <= 2 && i < g_streams.cap; i++) { stream_free_pushback(&g_streams.items[i]); stream_free_meta(&g_streams.items[i]); } // Close any non-standard streams left open in this worker. for (size_t i = 4; i < g_streams.cap; i++) { pl_stream *s = &g_streams.items[i]; if (!s->open) { continue; } if (s->fp) { (void)fclose(s->fp); } stream_free_pushback(s); stream_free_meta(s); *s = (pl_stream){0}; } // Restore standard streams each query for deterministic behavior. if (g_streams.cap >= 3) { g_streams.items[0] = (pl_stream){.open = true, .readable = true, .writable = false, .binary = false, .repositionable = false, .eof_action = PL_EOF_ACTION_RESET, .bom = false, .encoding = strdup("UTF-8"), .fp = stdin, .alias = strdup("user_input"), .file_name = strdup("stdin"), .line_count = 1, .line_pos = 1, .mode = strdup("read")}; g_streams.items[1] = (pl_stream){.open = true, .readable = false, .writable = true, .binary = false, .repositionable = false, .eof_action = PL_EOF_ACTION_RESET, .bom = false, .encoding = strdup("UTF-8"), .fp = stdout, .alias = strdup("user_output"), .file_name = strdup("stdout"), .line_count = 1, .line_pos = 1, .mode = strdup("append")}; g_streams.items[2] = (pl_stream){.open = true, .readable = false, .writable = true, .binary = false, .repositionable = false, .eof_action = PL_EOF_ACTION_RESET, .bom = false, .encoding = strdup("UTF-8"), .fp = stderr, .alias = strdup("user_error"), .file_name = strdup("stderr"), .line_count = 1, .line_pos = 1, .mode = strdup("append")}; } g_streams.current_input = 0; g_streams.current_output = 1; g_streams.next_id = 4; } /* --- SUBSECTION 08.3: Stream Lookup Helpers ------------------------------ */ // Stream lookup and id helpers. // stream_lookup(), stream_regular_file_at_end(), stream_alloc_id(), and term_stream_id() resolve stream terms and ids. static bool stream_lookup(SLO id, pl_stream **out, const ULO *dbg_dat_ptr) { streams_init(dbg_dat_ptr); if (id < 0 || (size_t)id >= g_streams.cap) { return false; } pl_stream *s = &g_streams.items[id]; if (!s->open || !s->fp) { return false; } if (out) { *out = s; } return true; } static bool stream_regular_file_at_end(const pl_stream *s) { if (!s || !s->fp) { return false; } const int fd = fileno(s->fp); if (fd < 0) { return false; } struct stat st; if (fstat(fd, &st) != 0) { return false; } if (!S_ISREG(st.st_mode)) { return false; } const long pos = ftell(s->fp); if (pos < 0) { return false; } return (off_t)pos >= st.st_size; } static SLO stream_alloc_id(const ULO *dbg_dat_ptr) { streams_init(dbg_dat_ptr); // Match Trealla's numbering: 0..2 reserved for std streams; ids are monotonic starting at 4. if (g_streams.next_id < 4) { g_streams.next_id = 4; } const SLO id = g_streams.next_id++; if (id < 0) { return -1; } streams_ensure_capacity(dbg_dat_ptr, (size_t)id + 1); return id; } static bool term_stream_id(pl_term *t, const pl_env *env, const ULO *dbg_dat_ptr, SLO *out_id) { t = deref_term(t, env); if (!t) { return false; } if (t->tag == PL_TERM_ATOM) { if (!strcmp(t->v.atom_name, "user_input")) { if (out_id) { *out_id = 0; } return true; } if (!strcmp(t->v.atom_name, "user_output")) { if (out_id) { *out_id = 1; } return true; } if (!strcmp(t->v.atom_name, "user_error")) { if (out_id) { *out_id = 2; } return true; } // Stream alias set via set_stream/2. streams_init(dbg_dat_ptr); for (size_t i = 0; i < g_streams.cap; i++) { const pl_stream *s = &g_streams.items[i]; if (!s->open || !s->alias) { continue; } if (!strcmp(s->alias, t->v.atom_name)) { if (out_id) { *out_id = (SLO)i; } return true; } } return false; } if (t->tag == PL_TERM_STRUCT && t->v.str.arity == 1 && !strcmp(t->v.str.functor, "$stream")) { pl_term *a0 = deref_term(t->v.str.args[0], env); if (!a0 || a0->tag != PL_TERM_INT) { return false; } if (out_id) { *out_id = a0->v.int_value; } return true; } return false; } // WAM equivalent of term_stream_id/4 (uses deref_term_wam + WAM bindings). static pl_term *deref_term_wam(pl_term *t); static bool term_stream_id_wam(pl_term *t, const ULO *dbg_dat_ptr, SLO *out_id) { t = deref_term_wam(t); if (!t) { return false; } if (t->tag == PL_TERM_ATOM) { if (!strcmp(t->v.atom_name, "user_input")) { if (out_id) { *out_id = 0; } return true; } if (!strcmp(t->v.atom_name, "user_output")) { if (out_id) { *out_id = 1; } return true; } if (!strcmp(t->v.atom_name, "user_error")) { if (out_id) { *out_id = 2; } return true; } // Stream alias set via set_stream/2. streams_init(dbg_dat_ptr); for (size_t i = 0; i < g_streams.cap; i++) { const pl_stream *s = &g_streams.items[i]; if (!s->open || !s->alias) { continue; } if (!strcmp(s->alias, t->v.atom_name)) { if (out_id) { *out_id = (SLO)i; } return true; } } return false; } if (t->tag == PL_TERM_STRUCT && t->v.str.arity == 1 && !strcmp(t->v.str.functor, "$stream")) { pl_term *a0 = deref_term_wam(t->v.str.args[0]); if (!a0 || a0->tag != PL_TERM_INT) { return false; } if (out_id) { *out_id = a0->v.int_value; } return true; } return false; } static pl_term *make_stream_term_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, SLO id) { pl_term *st = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$stream", 1); st->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return st; } /* ============================================================================ * SECTION 09: Memory & Allocation * pool/arena allocators and shared-memory helpers. * ============================================================================ */ /* --- SUBSECTION 09.1: Temp Allocation ------------------------------------ */ // Query-temporary allocation tracking and snapshots. // temp_alloc_push_*() registers allocations; temp_alloc_mark()/temp_alloc_release() roll them back; temp_snapshot_from_temp_alloc() captures OR-par state. static void temp_alloc_push_descr(pl_temp_alloc *ta, const ULO *dbg_dat_ptr, SLO descr) { if (!ta || !descr) { return; } if (ta->descr_count == ta->descr_cap) { size_t new_cap = ta->descr_cap ? (ta->descr_cap * 2) : 256; SLO *new_descrs = (SLO *)realloc(ta->descrs, new_cap * sizeof(SLO)); if (!new_descrs) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } ta->descrs = new_descrs; ta->descr_cap = new_cap; } ta->descrs[ta->descr_count++] = descr; } static void temp_alloc_push_pool_ptr(pl_temp_alloc *ta, const ULO *dbg_dat_ptr, void *ptr) { if (!ta || !ptr) { return; } if (ta->pool_count == ta->pool_cap) { size_t new_cap = ta->pool_cap ? (ta->pool_cap * 2) : 256; void **new_ptrs = (void **)realloc(ta->pool_ptrs, new_cap * sizeof(void *)); if (!new_ptrs) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } ta->pool_ptrs = new_ptrs; ta->pool_cap = new_cap; } ta->pool_ptrs[ta->pool_count++] = ptr; } static void temp_alloc_push_malloc_ptr(pl_temp_alloc *ta, const ULO *dbg_dat_ptr, void *ptr) { if (!ta || !ptr) { return; } if (ta->malloc_count == ta->malloc_cap) { size_t new_cap = ta->malloc_cap ? (ta->malloc_cap * 2) : 256; void **new_ptrs = (void **)realloc(ta->malloc_ptrs, new_cap * sizeof(void *)); if (!new_ptrs) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } ta->malloc_ptrs = new_ptrs; ta->malloc_cap = new_cap; } ta->malloc_ptrs[ta->malloc_count++] = ptr; } enum { FLOWLOG_LOCAL_ARENA_ALIGN = 16, FLOWLOG_LOCAL_ARENA_CHUNK_SIZE = 64 * 1024, // Above this threshold, allocate directly (tracked individually) so very // large transient blocks don't "steal" the arena cursor. FLOWLOG_LOCAL_ARENA_DIRECT_THRESHOLD = 32 * 1024, }; static inline size_t flowlog_align_up_size(size_t n, size_t align) { if (!align) { return n; } const size_t mask = align - 1; return (n + mask) & ~mask; } static void *temp_alloc_local_alloc(pl_temp_alloc *ta, size_t size, const ULO *dbg_dat_ptr) { if (!ta) { return NULL; } if (!size) { size = 1; } // Avoid consuming the arena for very large blocks (rare): allocate directly // and track the pointer for rollback. if (size >= (size_t)FLOWLOG_LOCAL_ARENA_DIRECT_THRESHOLD) { void *ptr = malloc(size); if (!ptr) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); return NULL; } temp_alloc_push_malloc_ptr(ta, dbg_dat_ptr, ptr); return ptr; } const size_t align = (size_t)FLOWLOG_LOCAL_ARENA_ALIGN; size_t off = flowlog_align_up_size(ta->arena_off, align); if (!ta->arena_cur || (off + size > ta->arena_cur_size)) { size_t chunk_size = (size_t)FLOWLOG_LOCAL_ARENA_CHUNK_SIZE; const size_t need = flowlog_align_up_size(size, align); if (chunk_size < need) { chunk_size = need; } unsigned char *chunk = (unsigned char *)malloc(chunk_size); if (!chunk) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); return NULL; } temp_alloc_push_malloc_ptr(ta, dbg_dat_ptr, chunk); ta->arena_cur = chunk; ta->arena_cur_size = chunk_size; ta->arena_off = 0; off = 0; } void *ptr = (void *)(ta->arena_cur + off); ta->arena_off = off + size; return ptr; } static void shm_free_descr(const void *rt_ctrl, const ULO *dbg_dat_ptr, SLO descr) { (void)rt_ctrl; (void)dbg_dat_ptr; (void)descr; } static pl_temp_mark temp_alloc_mark(const pl_temp_alloc *ta) { pl_temp_mark m = {0}; if (!ta) { return m; } m.descr_count = ta->descr_count; m.pool_count = ta->pool_count; m.malloc_count = ta->malloc_count; m.arena_cur = ta->arena_cur; m.arena_cur_size = ta->arena_cur_size; m.arena_off = ta->arena_off; return m; } static void temp_alloc_release(pl_temp_alloc *ta, pl_temp_mark mark, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!ta) { return; } while (ta->descr_count > mark.descr_count) { shm_free_descr(rt_ctrl, dbg_dat_ptr, ta->descrs[--ta->descr_count]); } while (ta->pool_count > mark.pool_count) { freepool(ta->pool_ptrs[--ta->pool_count]); } while (ta->malloc_count > mark.malloc_count) { free(ta->malloc_ptrs[--ta->malloc_count]); } ta->arena_cur = mark.arena_cur; ta->arena_cur_size = mark.arena_cur_size; ta->arena_off = mark.arena_off; } static pl_temp_alloc *temp_alloc_suspend(void) { pl_temp_alloc *saved = g_temp_alloc; g_temp_alloc = NULL; return saved; } static void temp_alloc_resume(pl_temp_alloc *saved) { g_temp_alloc = saved; } static void temp_alloc_free_all(pl_temp_alloc *ta, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!ta) { return; } for (size_t i = 0; i < ta->descr_count; i++) { shm_free_descr(rt_ctrl, dbg_dat_ptr, ta->descrs[i]); } for (size_t i = 0; i < ta->pool_count; i++) { freepool(ta->pool_ptrs[i]); } for (size_t i = 0; i < ta->malloc_count; i++) { free(ta->malloc_ptrs[i]); } free(ta->descrs); free(ta->pool_ptrs); free(ta->malloc_ptrs); memset(ta, 0, sizeof(*ta)); } static void temp_alloc_drop_lists(pl_temp_alloc *ta) { if (!ta) { return; } free(ta->descrs); free(ta->pool_ptrs); free(ta->malloc_ptrs); ta->descrs = NULL; ta->pool_ptrs = NULL; ta->malloc_ptrs = NULL; ta->descr_count = 0; ta->descr_cap = 0; ta->pool_count = 0; ta->pool_cap = 0; ta->malloc_count = 0; ta->malloc_cap = 0; ta->arena_cur = NULL; ta->arena_cur_size = 0; ta->arena_off = 0; } static void temp_alloc_adopt(pl_temp_alloc *dst, pl_temp_alloc *src, const ULO *dbg_dat_ptr) { if (!dst || !src) { return; } if (src->descr_count) { const size_t need = dst->descr_count + src->descr_count; if (need > dst->descr_cap) { size_t new_cap = dst->descr_cap ? dst->descr_cap : 64; while (new_cap < need) { new_cap *= 2; } SLO *new_items = (SLO *)realloc(dst->descrs, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } dst->descrs = new_items; dst->descr_cap = new_cap; } memcpy(dst->descrs + dst->descr_count, src->descrs, sizeof(*src->descrs) * src->descr_count); dst->descr_count += src->descr_count; } if (src->pool_count) { const size_t need = dst->pool_count + src->pool_count; if (need > dst->pool_cap) { size_t new_cap = dst->pool_cap ? dst->pool_cap : 64; while (new_cap < need) { new_cap *= 2; } void **new_items = (void **)realloc(dst->pool_ptrs, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } dst->pool_ptrs = new_items; dst->pool_cap = new_cap; } memcpy(dst->pool_ptrs + dst->pool_count, src->pool_ptrs, sizeof(*src->pool_ptrs) * src->pool_count); dst->pool_count += src->pool_count; } if (src->malloc_count) { const size_t need = dst->malloc_count + src->malloc_count; if (need > dst->malloc_cap) { size_t new_cap = dst->malloc_cap ? dst->malloc_cap : 64; while (new_cap < need) { new_cap *= 2; } void **new_items = (void **)realloc(dst->malloc_ptrs, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } dst->malloc_ptrs = new_items; dst->malloc_cap = new_cap; } memcpy(dst->malloc_ptrs + dst->malloc_count, src->malloc_ptrs, sizeof(*src->malloc_ptrs) * src->malloc_count); dst->malloc_count += src->malloc_count; } temp_alloc_drop_lists(src); } static pl_temp_snapshot *temp_snapshot_from_temp_alloc(const pl_temp_alloc *ta, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!ta || (!ta->descr_count && !ta->pool_count && !ta->malloc_count)) { return NULL; } // When local allocation is enabled (or when the temp allocator captured malloc pointers), // build the snapshot on the host heap. This keeps process-local pointers valid and // avoids involving the shared allocator from worker threads. const bool local = g_pool_local_alloc || (ta->malloc_count > 0); if (local) { pl_temp_snapshot *snap = (pl_temp_snapshot *)calloc(1, sizeof(*snap)); if (!snap) { return NULL; } if (ta->descr_count) { const size_t bytes = ta->descr_count * sizeof(SLO); SLO *arr = (SLO *)malloc(bytes); if (!arr) { return snap; } memcpy(arr, ta->descrs, bytes); snap->descrs = arr; snap->descr_count = ta->descr_count; } if (ta->pool_count) { const size_t bytes = ta->pool_count * sizeof(void *); void **arr = (void **)malloc(bytes); if (!arr) { return snap; } memcpy(arr, ta->pool_ptrs, bytes); snap->pool_ptrs = arr; snap->pool_count = ta->pool_count; } if (ta->malloc_count) { const size_t bytes = ta->malloc_count * sizeof(void *); void **arr = (void **)malloc(bytes); if (!arr) { return snap; } memcpy(arr, ta->malloc_ptrs, bytes); snap->malloc_ptrs = arr; snap->malloc_count = ta->malloc_count; } return snap; } SLO self_descr = 0; pl_temp_snapshot *snap = (pl_temp_snapshot *)shm_alloc(rt_ctrl, (SLO)sizeof(*snap), dbg_dat_ptr, &self_descr); if (!snap) { return NULL; } memset(snap, 0, sizeof(*snap)); snap->self_descr = self_descr; if (ta->descr_count) { const size_t bytes = ta->descr_count * sizeof(SLO); SLO arr_descr = 0; SLO *arr = (SLO *)shm_alloc(rt_ctrl, (SLO)bytes, dbg_dat_ptr, &arr_descr); if (!arr) { // Best effort: leave snapshot with no arrays; leaked allocations will be cleaned up on server shutdown. return snap; } memcpy(arr, ta->descrs, bytes); snap->descrs_descr = arr_descr; snap->descrs = arr; snap->descr_count = ta->descr_count; } if (ta->pool_count) { const size_t bytes = ta->pool_count * sizeof(void *); SLO arr_descr = 0; void **arr = (void **)shm_alloc(rt_ctrl, (SLO)bytes, dbg_dat_ptr, &arr_descr); if (!arr) { return snap; } memcpy(arr, ta->pool_ptrs, bytes); snap->pool_ptrs_descr = arr_descr; snap->pool_ptrs = arr; snap->pool_count = ta->pool_count; } return snap; } /* --- SUBSECTION 09.2: Shared Memory Helpers ------------------------------ */ // Shared-memory allocation wrapper. // shm_alloc() routes to reallocpool() and returns descriptors for temp tracking in parallel contexts. static void *shm_alloc(const void *rt_ctrl, SLO bytes, const ULO *dbg_dat_ptr, SLO *out_descr) { (void)rt_ctrl; (void)dbg_dat_ptr; if (bytes <= 0) { bytes = 1; } if (out_descr) { *out_descr = 0; } return reallocpool(NULL, (ULO)bytes); } /* --- SUBSECTION 09.3: Pool Allocation ------------------------------------ */ // Pool allocation helpers for runtime objects. // pool_alloc() and pool_strdup() choose local vs shared allocation and register with temp allocators. static void *pool_alloc(const void *rt_ctrl, ULO size, const ULO *dbg_dat_ptr) { if (!size) { size = 1; } SLO descr = 0; void *ptr = NULL; // For some parallel workloads (notably top-level OR-par via pl_or_prepare), // allocating all intermediate terms/envs from shared memory can become a // scalability bottleneck. When `g_pool_local_alloc` is enabled, and we are // allocating query-temporary memory (g_temp_alloc!=NULL), use process-local // heap allocation instead. const bool use_local = (g_temp_alloc && g_pool_local_alloc); if (use_local) { ptr = temp_alloc_local_alloc(g_temp_alloc, (size_t)size, dbg_dat_ptr); } else { ptr = shm_alloc(rt_ctrl, (SLO)size, dbg_dat_ptr, g_temp_alloc ? &descr : NULL); } if (!ptr) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, use_local ? "flowlog: out of memory" : "flowlog: out of shared memory", dbg_dat_ptr); } if (g_temp_alloc) { if (descr) { temp_alloc_push_descr(g_temp_alloc, dbg_dat_ptr, descr); } else if (!use_local) { temp_alloc_push_pool_ptr(g_temp_alloc, dbg_dat_ptr, ptr); } } return ptr; } static CHR *pool_strdup(const void *rt_ctrl, const CHR *s, const ULO *dbg_dat_ptr) { size_t n = strlen(s); CHR *copy = (CHR *)pool_alloc(rt_ctrl, (ULO)(n + 1), dbg_dat_ptr); memcpy(copy, s, n + 1); return copy; } /* ============================================================================ * SECTION 10: Lexer & Parser * tokenization, operator tables, and term parsing. * ============================================================================ */ /* --- SUBSECTION 10.1: Token Types & Lexer State -------------------------- */ // Lexer token types and state used by the parser. // lex_apply_char_conv() and lex_skip_ws_and_comments() handle conversions/whitespace; is_atom_start()/is_var_start() classify characters. typedef struct { const CHR *src; const CHR *cur; bool char_conv_on; const unsigned char *char_conv_table; // 256 entries, or NULL for identity bool character_escapes; bool hard_error; const CHR *hard_error_reason; const CHR *hard_error_pos; } pl_lex; typedef enum { TOK_EOF = 0, TOK_DOT, TOK_COMMA, TOK_LPAREN, TOK_RPAREN, TOK_LBRACK, TOK_RBRACK, TOK_BAR, TOK_COLON_DASH, TOK_ATOM, TOK_STRING, TOK_VAR, TOK_INT, TOK_FLOAT, TOK_ERROR, } pl_tok_type; typedef struct { pl_tok_type type; const CHR *start; ULO len; SLO ival; double fval; } pl_tok; static int hex_digit_val(unsigned char c); static unsigned char lex_apply_char_conv(const pl_lex *lx, unsigned char c) { if (lx && lx->char_conv_on && lx->char_conv_table) { return lx->char_conv_table[c]; } return c; } static void lex_init( pl_lex *lx, const CHR *src, bool char_conv_on, const unsigned char *char_conv_table, bool character_escapes) { lx->src = src; lx->cur = src; lx->char_conv_on = char_conv_on; lx->char_conv_table = char_conv_table; lx->character_escapes = character_escapes; lx->hard_error = false; lx->hard_error_reason = NULL; lx->hard_error_pos = NULL; } static void lex_skip_ws_and_comments(pl_lex *lx) { for (;;) { while (*lx->cur) { const unsigned char c = lex_apply_char_conv(lx, (unsigned char)*lx->cur); if (!isspace((int)c)) { break; } lx->cur++; } const unsigned char c0 = lex_apply_char_conv(lx, (unsigned char)lx->cur[0]); if (c0 == '%') { while (*lx->cur && (lex_apply_char_conv(lx, (unsigned char)*lx->cur) != '\n')) { lx->cur++; } continue; } const unsigned char c1 = lex_apply_char_conv(lx, (unsigned char)lx->cur[1]); if (c0 == '/' && c1 == '*') { lx->cur += 2; while (*lx->cur) { const unsigned char a = lex_apply_char_conv(lx, (unsigned char)lx->cur[0]); const unsigned char b = lex_apply_char_conv(lx, (unsigned char)lx->cur[1]); if (a == '*' && b == '/') { break; } lx->cur++; } if (*lx->cur) { lx->cur += 2; } continue; } break; } } static bool is_atom_start(int c) { return islower(c) || (c == '\''); } static bool is_var_start(int c) { return isupper(c) || (c == '_'); } static bool is_id_continue(int c) { return isalnum(c) || (c == '_'); } static bool is_symbol_atom_char(int c) { // ISO "graphic token" atoms, in a simplified form. // '.' is treated as part of a symbol atom when it is not a clause/query terminator. switch (c) { case '.': case '#': case '$': case '&': case '*': case '+': case '-': case '/': case ':': case '<': case '=': case '>': case '?': case '@': case '\\': case '^': case '~': case ';': return true; default: return false; } } /* --- SUBSECTION 10.2: Lexer Implementation ------------------------------- */ // Lexer core and token consumption helpers. // lex_next() produces tokens; peek_tok()/take_tok()/accept_tok() drive parser lookahead. static pl_tok lex_next(pl_lex *lx) { lx->hard_error = false; lx->hard_error_reason = NULL; lx->hard_error_pos = NULL; lex_skip_ws_and_comments(lx); pl_tok t = {0}; t.start = lx->cur; t.len = 1; const unsigned char raw = (unsigned char)*lx->cur; const unsigned char c = lex_apply_char_conv(lx, raw); if (!raw) { t.type = TOK_EOF; t.len = 0; return t; } if (c == '.') { // ISO full stop token: '.' followed by layout, comment, or EOF. // Otherwise '.' is part of a symbol atom (e.g. '=..', '.'(a,b)). const unsigned char raw_n = (unsigned char)lx->cur[1]; const unsigned char n = lex_apply_char_conv(lx, raw_n); const bool is_eof = (raw_n == '\0'); const bool is_layout = raw_n && isspace((int)n); const bool is_line_comment = (n == '%'); const bool is_block_comment = (n == '/' && lex_apply_char_conv(lx, (unsigned char)lx->cur[2]) == '*'); if (is_eof || is_layout || is_line_comment || is_block_comment) { lx->cur++; t.type = TOK_DOT; return t; } // fall through to symbol atom handling } if (c == ',' ) { lx->cur++; t.type = TOK_COMMA; return t; } if (c == '(' ) { lx->cur++; t.type = TOK_LPAREN; return t; } if (c == ')' ) { lx->cur++; t.type = TOK_RPAREN; return t; } if (c == '[' ) { lx->cur++; t.type = TOK_LBRACK; return t; } if (c == ']' ) { lx->cur++; t.type = TOK_RBRACK; return t; } if (c == '|' ) { lx->cur++; t.type = TOK_BAR; return t; } if (c == '!') { // ISO cut token is a solo-character atom; do not combine with '.'. lx->cur++; t.type = TOK_ATOM; return t; } if (c == ':' && lex_apply_char_conv(lx, (unsigned char)lx->cur[1]) == '-') { lx->cur += 2; t.type = TOK_COLON_DASH; t.len = 2; return t; } if (c == '"') { /* ISO double-quoted string token. Escapes are handled minimally, including * x-escape sequences terminated by a backslash. */ lx->cur++; // consume opening quote while (*lx->cur) { if (lx->character_escapes && lx->cur[0] == '\\' && lx->cur[1]) { const CHR *escape_start = lx->cur; const unsigned char esc = (unsigned char)lx->cur[1]; if (esc == 'x' || esc == 'X') { lx->cur += 2; // consume \x unsigned int v = 0; int digits = 0; bool saw_term = false; while (*lx->cur) { const unsigned char hc = (unsigned char)*lx->cur; if (hc == '\\') { lx->cur++; // consume terminating '\' saw_term = true; break; } const int hv = hex_digit_val(hc); if (hv < 0) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } v = (v * 16u) + (unsigned)hv; if (v > 255u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } digits++; lx->cur++; } if (saw_term && (!digits || v == 0u)) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = escape_start; t.type = TOK_ERROR; return t; } continue; } if (esc >= '0' && esc <= '7') { // ISO octal escape \ooo\ (terminated by backslash). lx->cur += 2; // consume backslash + first digit unsigned int v = (unsigned int)(esc - '0'); bool saw_term = false; while (*lx->cur) { const unsigned char oc = (unsigned char)*lx->cur; if (oc == '\\') { lx->cur++; // consume terminating '\' saw_term = true; break; } if (oc < '0' || oc > '7') { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } v = (v * 8u) + (unsigned)(oc - '0'); if (v > 255u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } lx->cur++; } if (saw_term && v == 0u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = escape_start; t.type = TOK_ERROR; return t; } continue; } switch (esc) { case 'a': case 'b': case 't': case 'n': case 'v': case 'f': case 'r': case 'e': case '\\': case '\'': case '"': lx->cur += 2; // generic 2-char escape continue; default: lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = escape_start; t.type = TOK_ERROR; return t; } } if (*lx->cur == '"') { if (lx->cur[1] == '"') { lx->cur += 2; // ISO quote-doubling: "" => " continue; } lx->cur++; // closing quote t.type = TOK_STRING; t.len = (ULO)(lx->cur - t.start); return t; } lx->cur++; } t.type = TOK_ERROR; return t; } if (isdigit((int)c)) { const CHR *start = lx->cur; // ISO character code constant: 0' (e.g. 0'a, 0'[). if (c == '0' && (lex_apply_char_conv(lx, (unsigned char)lx->cur[1]) == '\'')) { lx->cur += 2; // consume 0' const unsigned char raw_ch = (unsigned char)*lx->cur; if (!raw_ch) { t.type = TOK_ERROR; t.len = (ULO)(lx->cur - start); return t; } unsigned char ch = lex_apply_char_conv(lx, raw_ch); lx->cur++; // consume character (or escape marker) if (ch == '\\') { const CHR *escape_start = lx->cur - 1; const unsigned char raw_esc = (unsigned char)*lx->cur; if (!raw_esc) { t.type = TOK_ERROR; t.len = (ULO)(lx->cur - start); return t; } const unsigned char esc = lex_apply_char_conv(lx, raw_esc); // ISO-style escapes for character code constants are always interpreted (independent of character_escapes). if (esc == 'x' || esc == 'X') { lx->cur++; // consume 'x' unsigned int v = 0; int digits = 0; while (*lx->cur) { const unsigned char hc = (unsigned char)lex_apply_char_conv(lx, (unsigned char)*lx->cur); if (hc == '\\') { lx->cur++; // consume terminator break; } const int hv = hex_digit_val(hc); if (hv < 0) { digits = 0; break; } v = (v * 16u) + (unsigned)hv; digits++; lx->cur++; } if (digits <= 0 || v > 255u || v == 0u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; const CHR *err_pos = escape_start; if (digits <= 0) { if (!*lx->cur) { err_pos = escape_start; } else if (lx->cur > escape_start && lx->cur[-1] == '\\') { err_pos = escape_start; } else { err_pos = lx->cur; } } lx->hard_error_pos = err_pos; t.type = TOK_ERROR; t.len = (ULO)(lx->cur - start); return t; } ch = (unsigned char)v; } else if (esc >= '0' && esc <= '7') { lx->cur++; // consume first digit unsigned int v = (unsigned int)(esc - '0'); int digits = 1; while (*lx->cur) { const unsigned char oc = (unsigned char)lex_apply_char_conv(lx, (unsigned char)*lx->cur); if (oc == '\\') { lx->cur++; // consume terminator break; } if (oc < '0' || oc > '7') { digits = 0; break; } v = (v * 8u) + (unsigned)(oc - '0'); digits++; lx->cur++; } if (digits <= 0 || v > 255u || v == 0u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = (digits <= 0) ? lx->cur : escape_start; t.type = TOK_ERROR; t.len = (ULO)(lx->cur - start); return t; } ch = (unsigned char)v; } else { lx->cur++; // consume escape char switch (esc) { case 'a': ch = '\a'; break; case 'n': ch = '\n'; break; case 't': ch = '\t'; break; case 'r': ch = '\r'; break; case 'v': ch = '\v'; break; case 'b': ch = '\b'; break; case 'f': ch = '\f'; break; case 'e': ch = 0x1B; break; case '\\': ch = '\\'; break; case '\'': ch = '\''; break; case '"': ch = '"'; break; default: lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = escape_start; t.type = TOK_ERROR; t.len = (ULO)(lx->cur - start); return t; } } } t.type = TOK_INT; t.ival = (SLO)ch; t.len = (ULO)(lx->cur - start); return t; } while (*lx->cur && isdigit((int)lex_apply_char_conv(lx, (unsigned char)*lx->cur))) { lx->cur++; } bool is_float = false; if ((lex_apply_char_conv(lx, (unsigned char)lx->cur[0]) == '.') && isdigit((int)lex_apply_char_conv(lx, (unsigned char)lx->cur[1]))) { is_float = true; lx->cur++; // consume '.' while (*lx->cur && isdigit((int)lex_apply_char_conv(lx, (unsigned char)*lx->cur))) { lx->cur++; } } const unsigned char e = lex_apply_char_conv(lx, (unsigned char)lx->cur[0]); const unsigned char e1 = lex_apply_char_conv(lx, (unsigned char)lx->cur[1]); const unsigned char e2 = lex_apply_char_conv(lx, (unsigned char)lx->cur[2]); if ((e == 'e' || e == 'E') && (isdigit((int)e1) || ((e1 == '+' || e1 == '-') && isdigit((int)e2)))) { is_float = true; lx->cur++; // consume e/E const unsigned char sgn = lex_apply_char_conv(lx, (unsigned char)lx->cur[0]); if (sgn == '+' || sgn == '-') { lx->cur++; } while (*lx->cur && isdigit((int)lex_apply_char_conv(lx, (unsigned char)*lx->cur))) { lx->cur++; } } t.len = (ULO)(lx->cur - start); if (!is_float) { SLO v = 0; for (ULO i = 0; i < t.len; i++) { const unsigned char dc = lex_apply_char_conv(lx, (unsigned char)start[i]); const SLO digit = (SLO)(dc - '0'); if (v > (((SLO)LONG_MAX - digit) / 10)) { v = (SLO)LONG_MAX; break; } v = (v * 10) + digit; } t.type = TOK_INT; t.ival = v; return t; } // Convert float token via strtod. if (!t.len) { t.type = TOK_ERROR; return t; } if (t.len < 128) { char buf[128]; for (ULO i = 0; i < t.len; i++) { buf[i] = (char)lex_apply_char_conv(lx, (unsigned char)start[i]); } buf[t.len] = '\0'; char *end = NULL; errno = 0; double dv = strtod(buf, &end); if (errno || !end || (*end != '\0')) { t.type = TOK_ERROR; return t; } t.type = TOK_FLOAT; t.fval = dv; return t; } char *buf = (char *)malloc((size_t)t.len + 1); if (!buf) { t.type = TOK_ERROR; return t; } for (ULO i = 0; i < t.len; i++) { buf[i] = (char)lex_apply_char_conv(lx, (unsigned char)start[i]); } buf[t.len] = '\0'; char *end = NULL; errno = 0; double dv = strtod(buf, &end); free(buf); if (errno || !end || (*end != '\0')) { t.type = TOK_ERROR; return t; } t.type = TOK_FLOAT; t.fval = dv; return t; } // Non-ISO extension: allow `$foo`-style atom names (common for internal predicates in other systems). // Without this, `$foo` would tokenize as the symbol atom `$` followed by the bare atom `foo`. if (c == '$') { const unsigned char n = lex_apply_char_conv(lx, (unsigned char)lx->cur[1]); if (n && is_id_continue((int)n)) { lx->cur++; // consume '$' while (*lx->cur && is_id_continue((int)lex_apply_char_conv(lx, (unsigned char)*lx->cur))) { lx->cur++; } t.type = TOK_ATOM; t.len = (ULO)(lx->cur - t.start); return t; } } if (is_var_start((int)c)) { lx->cur++; while (*lx->cur && is_id_continue((int)lex_apply_char_conv(lx, (unsigned char)*lx->cur))) { lx->cur++; } t.type = TOK_VAR; t.len = (ULO)(lx->cur - t.start); return t; } if (is_atom_start((int)c)) { if (c == '\'') { lx->cur++; // consume opening quote while (*lx->cur) { /* Minimal escaping: \c, plus ISO hex escape \x...\, plus ISO quote-doubling: '' => '. */ if (lx->character_escapes && lx->cur[0] == '\\' && lx->cur[1]) { const CHR *escape_start = lx->cur; const unsigned char esc = (unsigned char)lx->cur[1]; if (esc == 'x' || esc == 'X') { lx->cur += 2; // consume \x unsigned int v = 0; int digits = 0; bool saw_term = false; while (*lx->cur) { const unsigned char hc = (unsigned char)*lx->cur; if (hc == '\\') { lx->cur++; // consume terminating '\' saw_term = true; break; } const int hv = hex_digit_val(hc); if (hv < 0) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } v = (v * 16u) + (unsigned)hv; if (v > 255u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } digits++; lx->cur++; } if (saw_term && (!digits || v == 0u)) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = escape_start; t.type = TOK_ERROR; return t; } continue; } if (esc >= '0' && esc <= '7') { // ISO octal escape \ooo\ (terminated by backslash). lx->cur += 2; // consume backslash + first digit unsigned int v = (unsigned int)(esc - '0'); bool saw_term = false; while (*lx->cur) { const unsigned char oc = (unsigned char)*lx->cur; if (oc == '\\') { lx->cur++; // consume terminating '\' saw_term = true; break; } if (oc < '0' || oc > '7') { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } v = (v * 8u) + (unsigned)(oc - '0'); if (v > 255u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = lx->cur; t.type = TOK_ERROR; return t; } lx->cur++; } if (saw_term && v == 0u) { lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = escape_start; t.type = TOK_ERROR; return t; } continue; } switch (esc) { case 'a': case 'b': case 't': case 'n': case 'v': case 'f': case 'r': case 'e': case '\\': case '\'': case '"': lx->cur += 2; continue; default: lx->hard_error = true; lx->hard_error_reason = "illegal_character_escape"; lx->hard_error_pos = escape_start; t.type = TOK_ERROR; return t; } } if (*lx->cur == '\'') { if (lx->cur[1] == '\'') { lx->cur += 2; continue; } lx->cur++; // closing quote t.type = TOK_ATOM; t.len = (ULO)(lx->cur - t.start); return t; } lx->cur++; } t.type = TOK_ERROR; return t; } lx->cur++; while (*lx->cur && is_id_continue((int)lex_apply_char_conv(lx, (unsigned char)*lx->cur))) { lx->cur++; } t.type = TOK_ATOM; t.len = (ULO)(lx->cur - t.start); return t; } if (is_symbol_atom_char((int)c)) { lx->cur++; while (*lx->cur && is_symbol_atom_char((int)lex_apply_char_conv(lx, (unsigned char)*lx->cur))) { lx->cur++; } t.type = TOK_ATOM; t.len = (ULO)(lx->cur - t.start); return t; } t.type = TOK_ERROR; return t; } typedef struct { pl_lex lx; pl_tok look; bool has_look; const char *src_name; ULO src_base_line; // 1-based file line offset for lx.src ULO src_base_col; // 1-based file column offset for lx.src const void *rt_ctrl; const ULO *dbg_dat_ptr; const pl_op_overrides *ops; pl_double_quotes_mode double_quotes; bool character_escapes; } pl_parse; static void rise_parse_error_expected_token(pl_parse *p, pl_tok got, pl_tok_type expected); static pl_tok peek_tok(pl_parse *p) { if (!p->has_look) { p->look = lex_next(&p->lx); p->has_look = true; } return p->look; } static pl_tok take_tok(pl_parse *p) { pl_tok t = peek_tok(p); p->has_look = false; return t; } static bool accept_tok(pl_parse *p, pl_tok_type ty) { if (peek_tok(p).type == ty) { (void)take_tok(p); return true; } return false; } static void expect_tok(pl_parse *p, pl_tok_type ty) { pl_tok t = take_tok(p); if (t.type != ty) { rise_parse_error_expected_token(p, t, ty); } } static const CHR *src_anchor_pos(const CHR *src, const CHR *pos) { if (!src || !pos || pos < src) { return pos; } // EOF is represented as a pointer to the NUL terminator. If the buffer ends // with a newline, anchoring on the NUL would point at an empty "next line". // Prefer to anchor diagnostics on the previous line's end. if (*pos == '\0' && pos > src && pos[-1] == '\n') { return pos - 1; } return pos; } static void compute_line_col(const CHR *src, const CHR *pos, ULO *out_line, ULO *out_col) { if (out_line) { *out_line = 0; } if (out_col) { *out_col = 0; } if (!src || !pos || pos < src) { return; } const CHR *end = src_anchor_pos(src, pos); ULO line = 1; ULO col = 1; for (const CHR *p = src; *p && p < end; p++) { if (*p == '\n') { line++; col = 1; } else { col++; } } if (out_line) { *out_line = line; } if (out_col) { *out_col = col; } } static int hex_digit_val(unsigned char c) { if (c >= '0' && c <= '9') { return (int)(c - '0'); } if (c >= 'a' && c <= 'f') { return 10 + (int)(c - 'a'); } if (c >= 'A' && c <= 'F') { return 10 + (int)(c - 'A'); } return -1; } static CHR *tok_to_cstr(pl_parse *p, pl_tok t) { const bool is_quoted_atom = (t.type == TOK_ATOM && t.len >= 2 && t.start[0] == '\'' && t.start[t.len - 1] == '\''); const bool is_string = (t.type == TOK_STRING && t.len >= 2 && t.start[0] == '"' && t.start[t.len - 1] == '"'); if (is_quoted_atom || is_string) { const CHR q = is_string ? '"' : '\''; const bool escapes_on = p ? p->character_escapes : true; const size_t cap = (size_t)t.len * PL_UTF8_MAX_BYTES + 1; if (!cap || cap < (size_t)t.len) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: string too large", p->dbg_dat_ptr); } CHR *out = (CHR *)pool_alloc(p->rt_ctrl, (ULO)cap, p->dbg_dat_ptr); ULO w = 0; for (ULO i = 1; i + 1 < t.len; i++) { const CHR c = t.start[i]; if (c == q && (i + 2 < t.len) && t.start[i + 1] == q) { // ISO quote-doubling: '' => ' and "" => ". out[w++] = q; i++; continue; } if (escapes_on && (c == '\\') && (i + 2 < t.len)) { const CHR e = t.start[i + 1]; if (e == 'x' || e == 'X') { uint32_t v = 0; int digits = 0; ULO j = i + 2; while (j + 1 < t.len) { const unsigned char hc = (unsigned char)t.start[j]; if (hc == '\\') { break; } const int hv = hex_digit_val(hc); if (hv < 0) { digits = 0; break; } v = (v * 16u) + (uint32_t)hv; digits++; j++; } if (digits > 0 && (j + 1 < t.len) && (t.start[j] == '\\') && unicode_codepoint_valid(v)) { const size_t n = utf8_encode_one(v, (unsigned char *)(out + w), cap - (size_t)w); if (!n || (w + n >= cap)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: string too large", p->dbg_dat_ptr); } w += (ULO)n; i = j; // skip digits and terminating '\' continue; } // Fall through to treat as an unknown/illegal escape. } if (e >= '0' && e <= '7') { // ISO octal escape \ooo\ (terminated by backslash). uint32_t v = (uint32_t)(e - '0'); int digits = 1; ULO j = i + 2; while (j + 1 < t.len) { const unsigned char oc = (unsigned char)t.start[j]; if (oc == '\\') { break; } if (oc < '0' || oc > '7') { digits = 0; break; } v = (v * 8u) + (uint32_t)(oc - '0'); digits++; j++; } if (digits > 0 && (j + 1 < t.len) && (t.start[j] == '\\') && unicode_codepoint_valid(v)) { const size_t n = utf8_encode_one(v, (unsigned char *)(out + w), cap - (size_t)w); if (!n || (w + n >= cap)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: string too large", p->dbg_dat_ptr); } w += (ULO)n; i = j; // skip digits and terminating '\' continue; } // Fall through to treat as an unknown/illegal escape. } if (e == 'a') { out[w++] = '\a'; i++; continue; } if (e == 'b') { out[w++] = '\b'; i++; continue; } if (e == 't') { out[w++] = '\t'; i++; continue; } if (e == 'n') { out[w++] = '\n'; i++; continue; } if (e == 'v') { out[w++] = '\v'; i++; continue; } if (e == 'f') { out[w++] = '\f'; i++; continue; } if (e == 'r') { out[w++] = '\r'; i++; continue; } if (e == 'e') { out[w++] = 0x1B; i++; continue; } if (e == '\\') { out[w++] = '\\'; i++; continue; } if (e == '\'') { out[w++] = '\''; i++; continue; } if (e == '"') { out[w++] = '"'; i++; continue; } rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: illegal character escape", p->dbg_dat_ptr); } out[w++] = c; } out[w] = '\0'; return out; } // Non-quoted atoms: copy and apply character conversion if enabled. CHR *buf = (CHR *)pool_alloc(p->rt_ctrl, t.len + 1, p->dbg_dat_ptr); memcpy(buf, t.start, t.len); buf[t.len] = '\0'; if (p && p->lx.char_conv_on && p->lx.char_conv_table) { for (ULO i = 0; i < t.len; i++) { buf[i] = (CHR)lex_apply_char_conv(&p->lx, (unsigned char)buf[i]); } } return buf; } static const char *tok_type_name(pl_tok_type ty) { switch (ty) { case TOK_EOF: return "TOK_EOF"; case TOK_DOT: return "TOK_DOT"; case TOK_COMMA: return "TOK_COMMA"; case TOK_LPAREN: return "TOK_LPAREN"; case TOK_RPAREN: return "TOK_RPAREN"; case TOK_LBRACK: return "TOK_LBRACK"; case TOK_RBRACK: return "TOK_RBRACK"; case TOK_BAR: return "TOK_BAR"; case TOK_COLON_DASH: return "TOK_COLON_DASH"; case TOK_ATOM: return "TOK_ATOM"; case TOK_STRING: return "TOK_STRING"; case TOK_VAR: return "TOK_VAR"; case TOK_INT: return "TOK_INT"; case TOK_FLOAT: return "TOK_FLOAT"; case TOK_ERROR: return "TOK_ERROR"; default: return "TOK_UNKNOWN"; } } static void msg_appendf(char *msg, size_t msg_sz, size_t *io_len, const char *fmt, ...) { if (!msg || !msg_sz || !io_len || !fmt) { return; } if (*io_len >= msg_sz) { return; } va_list ap; va_start(ap, fmt); const int n = vsnprintf(msg + *io_len, msg_sz - *io_len, fmt, ap); va_end(ap); if (n < 0) { return; } const size_t wrote = (size_t)n; if (wrote >= msg_sz - *io_len) { *io_len = msg_sz - 1; } else { *io_len += wrote; } } static void msg_append_location(char *msg, size_t msg_sz, size_t *io_len, const char *src_name, ULO line, ULO col) { const char *name = (src_name && *src_name) ? src_name : ""; if (line && col) { msg_appendf(msg, msg_sz, io_len, "\n at %s:%lu:%lu", name, (unsigned long)line, (unsigned long)col); } else if (line) { msg_appendf(msg, msg_sz, io_len, "\n at %s:%lu", name, (unsigned long)line); } else { msg_appendf(msg, msg_sz, io_len, "\n at %s", name); } } static void msg_append_caret_pad_from_excerpt( char *msg, size_t msg_sz, size_t *io_len, const char *excerpt, size_t caret_col) { if (!msg || !msg_sz || !io_len || !caret_col) { return; } const size_t excerpt_len = excerpt ? strlen(excerpt) : 0; for (size_t i = 0; i < caret_col; i++) { const char c = (excerpt && i < excerpt_len) ? excerpt[i] : ' '; if (c == '\t') { msg_appendf(msg, msg_sz, io_len, "\t"); } else { msg_appendf(msg, msg_sz, io_len, " "); } } } static void msg_append_line_excerpt_and_caret( char *msg, size_t msg_sz, size_t *io_len, ULO line, const char *excerpt, size_t caret_col) { if (!msg || !msg_sz || !io_len || !line || !excerpt || !excerpt[0]) { return; } char line_no[32]; (void)snprintf(line_no, sizeof(line_no), "%lu", (unsigned long)line); const size_t digits = strlen(line_no); msg_appendf(msg, msg_sz, io_len, "\n %s | %s", line_no, excerpt); msg_appendf(msg, msg_sz, io_len, "\n %*s | ", (int)digits, ""); msg_append_caret_pad_from_excerpt(msg, msg_sz, io_len, excerpt, caret_col); msg_appendf(msg, msg_sz, io_len, "^"); } static const char *parse_src_name(pl_parse *p) { if (p && p->src_name && *p->src_name) { return p->src_name; } return ""; } static void src_abs_line_col_from_base( const CHR *src, const CHR *pos, ULO base_line, ULO base_col, ULO *out_line, ULO *out_col) { if (out_line) { *out_line = 0; } if (out_col) { *out_col = 0; } if (!src || !pos || pos < src) { return; } ULO local_line = 0; ULO local_col = 0; compute_line_col(src, pos, &local_line, &local_col); if (!local_line) { return; } if (!base_line) { base_line = 1; } if (!base_col) { base_col = 1; } const ULO abs_line = base_line + (local_line - 1); ULO abs_col = 0; if (local_col) { abs_col = (local_line == 1) ? (base_col + (local_col - 1)) : local_col; } if (out_line) { *out_line = abs_line; } if (out_col) { *out_col = abs_col; } } static void parse_abs_line_col(pl_parse *p, const CHR *pos, ULO *out_line, ULO *out_col) { if (out_line) { *out_line = 0; } if (out_col) { *out_col = 0; } if (!p) { return; } src_abs_line_col_from_base( p->lx.src, pos, p->src_base_line ? p->src_base_line : 1, p->src_base_col ? p->src_base_col : 1, out_line, out_col); } static void tok_format_escaped(pl_tok t, char *out, size_t out_sz) { if (!out || !out_sz) { return; } if (t.type == TOK_EOF) { (void)snprintf(out, out_sz, ""); return; } if (!t.start || !t.len) { (void)snprintf(out, out_sz, ""); return; } char *w = out; size_t rem = out_sz; *w = '\0'; for (ULO i = 0; i < t.len; i++) { const unsigned char c = (unsigned char)t.start[i]; char esc[5] = {0}; const char *piece = NULL; size_t piece_len = 0; if (c == '\n') { piece = "\\n"; piece_len = 2; } else if (c == '\r') { piece = "\\r"; piece_len = 2; } else if (c == '\t') { piece = "\\t"; piece_len = 2; } else if (c == '\\') { piece = "\\\\"; piece_len = 2; } else if (isprint((int)c)) { esc[0] = (char)c; esc[1] = '\0'; piece = esc; piece_len = 1; } else { (void)snprintf(esc, sizeof(esc), "\\x%02X", (unsigned)c); piece = esc; piece_len = 4; } const bool last = ((i + 1u) == t.len); const size_t needed = piece_len + (last ? 1u : 4u); // +'\0' or +"..." + '\0' if (needed > rem) { // Truncated. const char dots[] = "..."; size_t dots_len = sizeof(dots) - 1; while (dots_len && rem > 1) { *w++ = dots[sizeof(dots) - 1 - dots_len]; dots_len--; rem--; } *w = '\0'; return; } memcpy(w, piece, piece_len); w += piece_len; rem -= piece_len; *w = '\0'; } } static void src_format_line_excerpt( const CHR *src, const CHR *pos, char *out, size_t out_sz, size_t *out_caret_col) { if (out_caret_col) { *out_caret_col = 0; } if (!out || !out_sz) { return; } out[0] = '\0'; if (!src || !pos || pos < src) { return; } pos = src_anchor_pos(src, pos); // Find the bounds of the line containing `pos`. const CHR *line_start = pos; while (line_start > src && line_start[-1] != '\n') { line_start--; } const CHR *line_end = pos; while (*line_end && *line_end != '\n') { line_end++; } const size_t line_len = (size_t)(line_end - line_start); const size_t off = (size_t)(pos - line_start); // Show a window around the error position, with optional ellipses. const size_t max_total = out_sz - 1; size_t window = 120; if (window > max_total) { window = max_total; } if (!window) { return; } size_t start = 0; size_t end = line_len; if (line_len > window) { const size_t half = window / 2; start = (off > half) ? (off - half) : 0; if (start + window > line_len) { start = line_len - window; } end = start + window; if (end > line_len) { end = line_len; } } const bool show_prefix = (start > 0); const bool show_suffix = (end < line_len); const size_t prefix_len = show_prefix ? 3 : 0; const size_t suffix_len = show_suffix ? 3 : 0; size_t body_len = end - start; if (prefix_len + body_len + suffix_len > max_total) { const size_t avail = (max_total > (prefix_len + suffix_len)) ? (max_total - prefix_len - suffix_len) : 0; body_len = (body_len > avail) ? avail : body_len; } char *w = out; if (show_prefix && (prefix_len < out_sz)) { memcpy(w, "...", 3); w += 3; } if (body_len) { memcpy(w, line_start + start, body_len); w += body_len; } if (show_suffix && ((size_t)(w - out) + 3 < out_sz)) { memcpy(w, "...", 3); w += 3; } *w = '\0'; if (out_caret_col) { const size_t caret = (off >= start) ? (prefix_len + (off - start)) : prefix_len; *out_caret_col = caret; } } static void report_stream_syntax_error(const char *src_name, ULO base_line, ULO base_col, const CHR *src, const CHR *pos, const CHR *reason) { if (!src_name || !*src_name) { src_name = ""; } if (!reason || !*reason) { reason = "syntax_error"; } if (!pos) { pos = src; } ULO line = 0; ULO col = 0; src_abs_line_col_from_base(src, pos, base_line, base_col, &line, &col); char line_excerpt[192]; size_t caret_col = 0; src_format_line_excerpt(src, pos, line_excerpt, sizeof(line_excerpt), &caret_col); char msg[1024]; size_t msg_len = 0; msg_appendf(msg, sizeof(msg), &msg_len, "flowlog: syntax error: %s", reason); msg_append_location(msg, sizeof(msg), &msg_len, src_name, line, col); if (!strcmp(reason, "illegal_character_escape")) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (invalid character escape in a quoted atom/string)"); } msg_append_line_excerpt_and_caret(msg, sizeof(msg), &msg_len, line, line_excerpt, caret_col); (void)fprintf(stderr, "%s\n", msg); } static const char *tok_expected_label(pl_tok_type ty, char *out, size_t out_sz) { if (!out || !out_sz) { return ""; } const char *punct = NULL; const char *word = NULL; switch (ty) { case TOK_EOF: word = "end of input"; break; case TOK_DOT: punct = "."; break; case TOK_COMMA: punct = ","; break; case TOK_LPAREN: punct = "("; break; case TOK_RPAREN: punct = ")"; break; case TOK_LBRACK: punct = "["; break; case TOK_RBRACK: punct = "]"; break; case TOK_BAR: punct = "|"; break; case TOK_COLON_DASH: punct = ":-"; break; case TOK_ATOM: word = "atom"; break; case TOK_STRING: word = "string"; break; case TOK_VAR: word = "variable"; break; case TOK_INT: word = "integer"; break; case TOK_FLOAT: word = "float"; break; case TOK_ERROR: word = "token"; break; default: word = "token"; break; } if (punct) { (void)snprintf(out, out_sz, "'%s'", punct); } else { (void)snprintf(out, out_sz, "%s", word ? word : "token"); } return out; } static bool tok_type_starts_term(pl_tok_type ty) { switch (ty) { case TOK_LPAREN: case TOK_LBRACK: case TOK_ATOM: case TOK_STRING: case TOK_INT: case TOK_FLOAT: case TOK_VAR: return true; default: return false; } } /* --- SUBSECTION 10.3: Parse Error Reporting ------------------------------ */ // Parse error reporting helpers. // rise_parse_error_expected_token() and rise_unexpected_token_term() build errors; var_table_intern() tracks named variables. static void rise_parse_error_expected_token(pl_parse *p, pl_tok got, pl_tok_type expected) { const CHR *src = p ? p->lx.src : NULL; const char *src_name = parse_src_name(p); const CHR *pos = got.start; if (got.type == TOK_ERROR && p && p->lx.hard_error && p->lx.hard_error_pos) { pos = p->lx.hard_error_pos; } ULO line = 0; ULO col = 0; parse_abs_line_col(p, pos, &line, &col); char got_buf[128]; tok_format_escaped(got, got_buf, sizeof(got_buf)); char expected_label[48]; tok_expected_label(expected, expected_label, sizeof(expected_label)); char line_excerpt[192]; size_t caret_col = 0; src_format_line_excerpt(src, pos, line_excerpt, sizeof(line_excerpt), &caret_col); char msg[1024]; size_t msg_len = 0; if (expected == TOK_DOT) { msg_appendf(msg, sizeof(msg), &msg_len, "flowlog: parse error: unexpected token after term: %s (%s); expected %s (%s)", got_buf, tok_type_name(got.type), expected_label, tok_type_name(expected)); } else { msg_appendf(msg, sizeof(msg), &msg_len, "flowlog: parse error: expected %s (%s) but found %s (%s)", expected_label, tok_type_name(expected), got_buf, tok_type_name(got.type)); } msg_append_location(msg, sizeof(msg), &msg_len, src_name, line, col); if (expected == TOK_DOT) { if (got.type == TOK_EOF) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (clauses and queries must end with '.')"); } else { msg_appendf(msg, sizeof(msg), &msg_len, "\n (unexpected token after a complete term; check for a missing ',' between goals or a missing operator)"); } } else if (expected == TOK_RPAREN) { if (tok_type_starts_term(got.type)) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (arguments must be separated with ',')"); } else { msg_appendf(msg, sizeof(msg), &msg_len, "\n (missing ')')"); } } else if (expected == TOK_RBRACK) { if (tok_type_starts_term(got.type)) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (list elements must be separated with ',')"); } else { msg_appendf(msg, sizeof(msg), &msg_len, "\n (missing ']')"); } } else if (expected == TOK_EOF) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (unexpected extra input)"); } if (got.type == TOK_EOF) { if (expected != TOK_DOT) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (input ended unexpectedly)"); } } else if (got.type == TOK_VAR) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (note: identifiers starting with uppercase or '_' are variables; atoms/operators are lowercase or quoted)"); } else if (got.type == TOK_ERROR && p && p->lx.hard_error && p->lx.hard_error_reason) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (lexer error: %s)", p->lx.hard_error_reason); } msg_append_line_excerpt_and_caret(msg, sizeof(msg), &msg_len, line, line_excerpt, caret_col); rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, msg, p ? p->dbg_dat_ptr : NULL); } static void rise_unexpected_token_term(pl_parse *p, pl_tok t, bool allow_vars) { const CHR *src = p ? p->lx.src : NULL; const char *src_name = parse_src_name(p); const CHR *pos = t.start; if (t.type == TOK_ERROR && p && p->lx.hard_error && p->lx.hard_error_pos) { pos = p->lx.hard_error_pos; } ULO line = 0; ULO col = 0; parse_abs_line_col(p, pos, &line, &col); char tok_buf[128]; tok_format_escaped(t, tok_buf, sizeof(tok_buf)); const char *expect = allow_vars ? "one of: '(', '[', atom, string, number, variable" : "one of: '(', '[', atom, string, number"; char line_excerpt[192]; size_t caret_col = 0; src_format_line_excerpt(src, pos, line_excerpt, sizeof(line_excerpt), &caret_col); char msg[1024]; size_t msg_len = 0; msg_appendf(msg, sizeof(msg), &msg_len, "flowlog: unexpected token while parsing term: %s (%s)", tok_buf, tok_type_name(t.type)); msg_append_location(msg, sizeof(msg), &msg_len, src_name, line, col); msg_appendf(msg, sizeof(msg), &msg_len, "\n expected %s", expect); if (t.type == TOK_EOF) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (input ended while a term was expected)"); } else if (t.type == TOK_DOT) { msg_appendf(msg, sizeof(msg), &msg_len, "\n ('.' terminates a clause/query; a term was expected before it)"); } else if (t.type == TOK_COMMA) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (',' separates arguments/goals; a term was expected before it)"); } else if (t.type == TOK_RPAREN) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (')' closes a group/call; a term was expected before it)"); } else if (t.type == TOK_RBRACK) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (']' closes a list; a term was expected before it)"); } else if (t.type == TOK_BAR) { msg_appendf(msg, sizeof(msg), &msg_len, "\n ('|' is used for list tails [H|T]; a term was expected here)"); } else if (t.type == TOK_ERROR && p && p->lx.hard_error && p->lx.hard_error_reason) { msg_appendf(msg, sizeof(msg), &msg_len, "\n (lexer error: %s)", p->lx.hard_error_reason); } msg_append_line_excerpt_and_caret(msg, sizeof(msg), &msg_len, line, line_excerpt, caret_col); rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, msg, p ? p->dbg_dat_ptr : NULL); } static pl_term *make_atom(pl_parse *p, const CHR *name) { pl_term *t = (pl_term *)pool_alloc(p->rt_ctrl, sizeof(*t), p->dbg_dat_ptr); t->tag = PL_TERM_ATOM; t->builtin = builtin_id_from_name_arity(name, 0); t->reserved16 = arith_id_from_name_arity(name, 0); t->v.atom_name = pool_strdup(p->rt_ctrl, name, p->dbg_dat_ptr); return t; } static pl_term *make_int(pl_parse *p, SLO v) { pl_term *t = (pl_term *)pool_alloc(p->rt_ctrl, sizeof(*t), p->dbg_dat_ptr); t->tag = PL_TERM_INT; t->builtin = 0; t->reserved16 = 0; t->v.int_value = v; return t; } static pl_term *make_bigint(pl_parse *p, pl_bigint *b) { if (!b) { return make_int(p, 0); } SLO v = 0; if (bigint_fits_slo(b, &v)) { return make_int(p, v); } pl_term *t = (pl_term *)pool_alloc(p->rt_ctrl, sizeof(*t), p->dbg_dat_ptr); t->tag = PL_TERM_BIGINT; t->builtin = 0; t->reserved16 = 0; t->v.bigint = b; return t; } static pl_term *make_int_from_tok(pl_parse *p, const pl_tok t) { if (!p || !t.start || !t.len) { return make_int(p, 0); } if (t.len >= 2 && t.start[0] == '0' && t.start[1] == '\'') { return make_int(p, t.ival); } SLO v = 0; bool overflow = false; for (ULO i = 0; i < t.len; i++) { const unsigned char dc = (unsigned char)t.start[i]; if (dc < '0' || dc > '9') { overflow = true; break; } const SLO digit = (SLO)(dc - '0'); if (v > (((SLO)LONG_MAX - digit) / 10)) { overflow = true; break; } v = (v * 10) + digit; } if (!overflow) { return make_int(p, v); } pl_bigint *big = bigint_from_cstr_base(t.start, (size_t)t.len, 10, 1, p->rt_ctrl, p->dbg_dat_ptr); if (!big) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", p->dbg_dat_ptr); } return make_bigint(p, big); } static pl_term *make_float(pl_parse *p, double v) { pl_term *t = (pl_term *)pool_alloc(p->rt_ctrl, sizeof(*t), p->dbg_dat_ptr); t->tag = PL_TERM_FLOAT; t->builtin = 0; t->reserved16 = 0; t->v.float_value = v; return t; } static pl_term *make_var(pl_parse *p, const pl_scope *scope, ULO var_id, const CHR *name) { pl_term *t = (pl_term *)pool_alloc(p->rt_ctrl, sizeof(*t), p->dbg_dat_ptr); t->tag = PL_TERM_VAR; t->builtin = 0; t->reserved16 = 0; t->v.var.scope = scope; t->v.var.var_id = var_id; t->v.var.var_name = pool_strdup(p->rt_ctrl, name, p->dbg_dat_ptr); return t; } static pl_term *make_struct(pl_parse *p, const CHR *functor, ULO arity) { pl_term *t = (pl_term *)pool_alloc(p->rt_ctrl, sizeof(*t), p->dbg_dat_ptr); t->tag = PL_TERM_STRUCT; t->builtin = builtin_id_from_name_arity(functor, arity); t->reserved16 = arith_id_from_name_arity(functor, arity); t->v.str.arity = arity; t->v.str.functor = pool_strdup(p->rt_ctrl, functor, p->dbg_dat_ptr); if (arity) { t->v.str.args = (pl_term **)pool_alloc(p->rt_ctrl, sizeof(pl_term *) * arity, p->dbg_dat_ptr); } else { t->v.str.args = NULL; } return t; } static pl_term *make_pstr_alloc_raw(const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO len, pl_term *tail, unsigned char **out_payload) { if (!tail) { tail = make_nil_rt(dbg_dat_ptr); } if (!len) { return tail; } const size_t align = sizeof(void *); const size_t raw = sizeof(pl_term) + ((size_t)len + 1u); const size_t tail_off = (raw + align - 1) & ~(align - 1); const size_t total = tail_off + sizeof(pl_term *); pl_term *t = (pl_term *)pool_alloc(rt_ctrl, (ULO)total, dbg_dat_ptr); t->tag = PL_TERM_PSTR; t->builtin = 0; t->reserved16 = 0; unsigned char *dst = (unsigned char *)(t + 1); dst[len] = 0; unsigned char *after = dst + len + 1; unsigned char *tail_slot_bytes = (unsigned char *)t + tail_off; if (tail_slot_bytes > after) { memset(after, 0, (size_t)(tail_slot_bytes - after)); } *(pl_term **)tail_slot_bytes = tail; t->v.pstr.bytes = dst; if (out_payload) { *out_payload = dst; } return t; } static pl_term *make_pstr_bytes_alloc(const void *rt_ctrl, const ULO *dbg_dat_ptr, const unsigned char *bytes, ULO len, pl_term *tail) { if (!bytes || !len) { return tail ? tail : make_nil_rt(dbg_dat_ptr); } unsigned char *dst = NULL; pl_term *t = make_pstr_alloc_raw(rt_ctrl, dbg_dat_ptr, len, tail, &dst); if (!t || !dst || t == tail) { return t; } memcpy(dst, bytes, (size_t)len); return t; } static pl_term *make_pstr_bytes_ref(const void *rt_ctrl, const ULO *dbg_dat_ptr, const unsigned char *bytes) { if (!bytes) { return make_nil_rt(dbg_dat_ptr); } pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_PSTR; t->builtin = 0; t->reserved16 = 0; t->v.pstr.bytes = bytes; return t; } static pl_term *make_pstr_utf8_alloc(const void *rt_ctrl, const ULO *dbg_dat_ptr, const unsigned char *bytes, ULO len, pl_term *tail) { if (!bytes || !len) { return tail ? tail : make_nil_rt(dbg_dat_ptr); } return make_pstr_bytes_alloc(rt_ctrl, dbg_dat_ptr, bytes, len, tail); } static pl_term *make_pstr(pl_parse *p, const unsigned char *bytes, ULO len, pl_term *tail) { if (!p || !tail) { return NULL; } return make_pstr_utf8_alloc(p->rt_ctrl, p->dbg_dat_ptr, bytes, len, tail); } typedef struct { CHR **names; ULO count; ULO cap; } pl_var_table; static ULO var_table_intern(pl_parse *p, pl_var_table *vt, const CHR *name) { if (name && name[0] == '_' && name[1] == '\0') { // Anonymous variable '_' is always distinct, so do not intern it. if (vt->count == vt->cap) { ULO new_cap = vt->cap ? (vt->cap * 2) : 8; CHR **new_names = (CHR **)pool_alloc(p->rt_ctrl, sizeof(CHR *) * new_cap, p->dbg_dat_ptr); if (vt->names) { memcpy(new_names, vt->names, sizeof(CHR *) * vt->count); } vt->names = new_names; vt->cap = new_cap; } vt->names[vt->count] = pool_strdup(p->rt_ctrl, name, p->dbg_dat_ptr); return vt->count++; } for (ULO i = 0; i < vt->count; i++) { if (!strcmp(vt->names[i], name)) { return i; } } if (vt->count == vt->cap) { ULO new_cap = vt->cap ? (vt->cap * 2) : 8; CHR **new_names = (CHR **)pool_alloc(p->rt_ctrl, sizeof(CHR *) * new_cap, p->dbg_dat_ptr); if (vt->names) { memcpy(new_names, vt->names, sizeof(CHR *) * vt->count); } vt->names = new_names; vt->cap = new_cap; } vt->names[vt->count] = pool_strdup(p->rt_ctrl, name, p->dbg_dat_ptr); return vt->count++; } typedef struct { pl_term *term; int prec; } pl_parse_term; /* --- SUBSECTION 10.4: Operator Table & Overrides ------------------------ */ // Operator-table lookup helper. // tok_eq_str() compares tokens against operator names for precedence handling. typedef enum { PL_OP_INFIX_XFX, PL_OP_INFIX_XFY, PL_OP_INFIX_YFX, PL_OP_PREFIX_FX, PL_OP_PREFIX_FY, PL_OP_POSTFIX_XF, PL_OP_POSTFIX_YF, } pl_op_fix; typedef struct { const char *name; int prec; pl_op_fix fix; } pl_op_decl; struct pl_op_overrides { pl_op_decl *items; ULO count; ULO cap; }; static pl_op_overrides *op_overrides_create(const void *rt_ctrl, const ULO *dbg_dat_ptr) { // Allocate in the shared-memory pool. When a temp allocator is active this // will be released at the end of the query; otherwise it behaves as a // persistent allocation for long-lived programs. pl_op_overrides *ov = (pl_op_overrides *)pool_alloc(rt_ctrl, sizeof(*ov), dbg_dat_ptr); memset(ov, 0, sizeof(*ov)); return ov; } static pl_op_decl *op_override_find(const pl_op_overrides *ov, const char *name, pl_op_fix fix) { if (!ov || !name) { return NULL; } for (ULO i = 0; i < ov->count; i++) { pl_op_decl *op = &ov->items[i]; if (op->fix == fix && !strcmp(op->name, name)) { return op; } } return NULL; } static pl_op_decl *op_override_set(pl_program *prog, const char *name, pl_op_fix fix, int prec, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !name) { return NULL; } if (!prog->op_overrides) { prog->op_overrides = op_overrides_create(rt_ctrl, dbg_dat_ptr); } pl_op_overrides *ov = prog->op_overrides; pl_op_decl *existing = op_override_find(ov, name, fix); if (existing) { existing->prec = prec; return existing; } if (ov->count == ov->cap) { ULO new_cap = ov->cap ? (ov->cap * 2) : 16; pl_op_decl *new_items = (pl_op_decl *)pool_alloc(rt_ctrl, sizeof(pl_op_decl) * new_cap, dbg_dat_ptr); if (ov->items && ov->count) { memcpy(new_items, ov->items, sizeof(pl_op_decl) * ov->count); } ov->items = new_items; ov->cap = new_cap; } pl_op_decl *op = &ov->items[ov->count++]; op->name = pool_strdup(rt_ctrl, name, dbg_dat_ptr); op->prec = prec; op->fix = fix; return op; } // Minimal ISO operator table (enough for core syntax; expands over time). static const pl_op_decl PL_OPS[] = { {":-", 1200, PL_OP_INFIX_XFX}, {":-", 1200, PL_OP_PREFIX_FX}, // Allow `|` outside of list syntax (e.g. prologue-style alternative answers and future DCGs). // Kept at a precedence > 999 so it doesn't interfere with list tails parsed at precedence 999. {"|", 1150, PL_OP_INFIX_XFY}, {"|", 1150, PL_OP_PREFIX_FY}, {";", 1100, PL_OP_INFIX_XFY}, {"->", 1050, PL_OP_INFIX_XFY}, {",", 1000, PL_OP_INFIX_XFY}, {"\\+", 900, PL_OP_PREFIX_FY}, {"=", 700, PL_OP_INFIX_XFX}, {"=..", 700, PL_OP_INFIX_XFX}, {"\\=", 700, PL_OP_INFIX_XFX}, {"==", 700, PL_OP_INFIX_XFX}, {"\\==", 700, PL_OP_INFIX_XFX}, {"=@=", 700, PL_OP_INFIX_XFX}, {"\\=@=", 700, PL_OP_INFIX_XFX}, {"is", 700, PL_OP_INFIX_XFX}, {"=:=", 700, PL_OP_INFIX_XFX}, {"=\\=", 700, PL_OP_INFIX_XFX}, {"<", 700, PL_OP_INFIX_XFX}, {"=<", 700, PL_OP_INFIX_XFX}, {">", 700, PL_OP_INFIX_XFX}, {">=", 700, PL_OP_INFIX_XFX}, {"@<", 700, PL_OP_INFIX_XFX}, {"@=<", 700, PL_OP_INFIX_XFX}, {"@>", 700, PL_OP_INFIX_XFX}, {"@>=", 700, PL_OP_INFIX_XFX}, {":", 600, PL_OP_INFIX_XFY}, {"+", 500, PL_OP_INFIX_YFX}, {"-", 500, PL_OP_INFIX_YFX}, {"/\\", 500, PL_OP_INFIX_YFX}, {"\\/", 500, PL_OP_INFIX_YFX}, {"*", 400, PL_OP_INFIX_YFX}, {"/", 400, PL_OP_INFIX_YFX}, {"//", 400, PL_OP_INFIX_YFX}, {"<<", 400, PL_OP_INFIX_YFX}, {">>", 400, PL_OP_INFIX_YFX}, {"xor", 400, PL_OP_INFIX_YFX}, {"div", 400, PL_OP_INFIX_YFX}, {"mod", 400, PL_OP_INFIX_YFX}, {"rem", 400, PL_OP_INFIX_YFX}, {"**", 200, PL_OP_INFIX_XFY}, {"^", 200, PL_OP_INFIX_XFY}, {"+", 200, PL_OP_PREFIX_FY}, {"-", 200, PL_OP_PREFIX_FY}, {"\\", 200, PL_OP_PREFIX_FY}, }; static bool tok_eq_str(const pl_lex *lx, pl_tok t, const char *s) { const size_t n = strlen(s); if (t.type == TOK_COMMA) { return (n == 1) && (s[0] == ','); } if (t.type == TOK_BAR) { return (n == 1) && (s[0] == '|'); } if (t.type == TOK_COLON_DASH) { return (n == 2) && (s[0] == ':') && (s[1] == '-'); } if (t.type != TOK_ATOM) { return false; } // Treat quoted atoms as non-operators. if (t.start && t.len && (t.start[0] == '\'')) { return false; } if (!lx || !lx->char_conv_on || !lx->char_conv_table) { return (t.len == (ULO)n) && !memcmp(t.start, s, n); } if (t.len != (ULO)n) { return false; } for (size_t i = 0; i < n; i++) { const unsigned char c = lex_apply_char_conv(lx, (unsigned char)t.start[i]); if (c != (unsigned char)s[i]) { return false; } } return true; } static const pl_op_decl *lookup_prefix_op(const pl_op_overrides *ov, const pl_lex *lx, pl_tok t) { if (ov) { for (ULO i = 0; i < ov->count; i++) { const pl_op_decl *op = &ov->items[i]; if ((op->fix == PL_OP_PREFIX_FX || op->fix == PL_OP_PREFIX_FY) && tok_eq_str(lx, t, op->name)) { return op->prec ? op : NULL; } } } for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *op = &PL_OPS[i]; if ((op->fix == PL_OP_PREFIX_FX || op->fix == PL_OP_PREFIX_FY) && tok_eq_str(lx, t, op->name)) { return op; } } return NULL; } static const pl_op_decl *lookup_infix_op(const pl_op_overrides *ov, const pl_lex *lx, pl_tok t) { if (ov) { for (ULO i = 0; i < ov->count; i++) { const pl_op_decl *op = &ov->items[i]; if ((op->fix == PL_OP_INFIX_XFX || op->fix == PL_OP_INFIX_XFY || op->fix == PL_OP_INFIX_YFX) && tok_eq_str(lx, t, op->name)) { return op->prec ? op : NULL; } } } for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *op = &PL_OPS[i]; if ((op->fix == PL_OP_INFIX_XFX || op->fix == PL_OP_INFIX_XFY || op->fix == PL_OP_INFIX_YFX) && tok_eq_str(lx, t, op->name)) { return op; } } return NULL; } static const pl_op_decl *lookup_postfix_op(const pl_op_overrides *ov, const pl_lex *lx, pl_tok t) { if (ov) { for (ULO i = 0; i < ov->count; i++) { const pl_op_decl *op = &ov->items[i]; if ((op->fix == PL_OP_POSTFIX_XF || op->fix == PL_OP_POSTFIX_YF) && tok_eq_str(lx, t, op->name)) { return op->prec ? op : NULL; } } } for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *op = &PL_OPS[i]; if ((op->fix == PL_OP_POSTFIX_XF || op->fix == PL_OP_POSTFIX_YF) && tok_eq_str(lx, t, op->name)) { return op; } } return NULL; } /* --- SUBSECTION 10.5: Parser Core ---------------------------------------- */ // Parser core for terms and goal lists. // parse_primary_op() parses terms, goals_append() grows goal arrays, and flatten_conjunction_goals() normalizes ',' goals. static pl_parse_term parse_term_op(pl_parse *p, pl_var_table *vt, const pl_scope *scope, bool allow_vars, int max_prec); static pl_term *parse_term(pl_parse *p, pl_var_table *vt, const pl_scope *scope, bool allow_vars, int max_prec); static pl_term *parse_list(pl_parse *p, pl_var_table *vt, const pl_scope *scope, bool allow_vars) { // '[' already consumed if (accept_tok(p, TOK_RBRACK)) { return make_atom(p, "[]"); } // Collect elements pl_term **elems = NULL; ULO elems_n = 0; ULO elems_cap = 0; pl_term *tail = NULL; for (;;) { pl_term *elem = parse_term(p, vt, scope, allow_vars, 999); if (elems_n == elems_cap) { ULO new_cap = elems_cap ? elems_cap * 2 : 8; pl_term **new_elems = (pl_term **)pool_alloc(p->rt_ctrl, sizeof(pl_term *) * new_cap, p->dbg_dat_ptr); if (elems) { memcpy(new_elems, elems, sizeof(pl_term *) * elems_n); } elems = new_elems; elems_cap = new_cap; } elems[elems_n++] = elem; if (accept_tok(p, TOK_COMMA)) { continue; } if (accept_tok(p, TOK_BAR)) { tail = parse_term(p, vt, scope, allow_vars, 999); expect_tok(p, TOK_RBRACK); break; } expect_tok(p, TOK_RBRACK); break; } if (!tail) { tail = make_atom(p, "[]"); } // Build '.'(Head, Tail) from the end for (ULO i = elems_n; i > 0; i--) { pl_term *cons = make_struct(p, ".", 2); cons->v.str.args[0] = elems[i - 1]; cons->v.str.args[1] = tail; tail = cons; } return tail; } static pl_parse_term parse_primary_op(pl_parse *p, pl_var_table *vt, const pl_scope *scope, bool allow_vars) { pl_tok t = take_tok(p); if (t.type == TOK_LPAREN) { pl_parse_term inner = parse_term_op(p, vt, scope, allow_vars, 1200); expect_tok(p, TOK_RPAREN); return (pl_parse_term){.term = inner.term, .prec = 0}; } if (t.type == TOK_ATOM) { CHR *name = tok_to_cstr(p, t); if (accept_tok(p, TOK_LPAREN)) { // arguments pl_term **args = NULL; ULO arity = 0; ULO cap = 0; if (!accept_tok(p, TOK_RPAREN)) { for (;;) { pl_term *arg = parse_term(p, vt, scope, allow_vars, 999); if (arity == cap) { ULO new_cap = cap ? cap * 2 : 4; pl_term **new_args = (pl_term **)pool_alloc(p->rt_ctrl, sizeof(pl_term *) * new_cap, p->dbg_dat_ptr); if (args) { memcpy(new_args, args, sizeof(pl_term *) * arity); } args = new_args; cap = new_cap; } args[arity++] = arg; if (accept_tok(p, TOK_COMMA)) { continue; } expect_tok(p, TOK_RPAREN); break; } } // Fold unary +/- onto numeric literals so '-(2)' parses as the integer -2 // (and not the term -(2)). If the caller needs the functor form, it can // be written as '-'(2). if (arity == 1 && (!strcmp(name, "+") || !strcmp(name, "-"))) { if (args[0] && args[0]->tag == PL_TERM_INT) { const SLO v = args[0]->v.int_value; return (pl_parse_term){.term = make_int(p, !strcmp(name, "-") ? -v : v), .prec = 0}; } if (args[0] && args[0]->tag == PL_TERM_BIGINT) { if (!strcmp(name, "-")) { pl_bigint *neg = bigint_negate(args[0]->v.bigint, p->rt_ctrl, p->dbg_dat_ptr); return (pl_parse_term){.term = make_bigint(p, neg), .prec = 0}; } return (pl_parse_term){.term = args[0], .prec = 0}; } if (args[0] && args[0]->tag == PL_TERM_FLOAT) { const double v = args[0]->v.float_value; return (pl_parse_term){.term = make_float(p, !strcmp(name, "-") ? -v : v), .prec = 0}; } } pl_term *st = make_struct(p, name, arity); for (ULO i = 0; i < arity; i++) { st->v.str.args[i] = args[i]; } return (pl_parse_term){.term = st, .prec = 0}; } return (pl_parse_term){.term = make_atom(p, name), .prec = 0}; } if (t.type == TOK_STRING) { CHR *s = tok_to_cstr(p, t); if (!s) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid string token", p->dbg_dat_ptr); } if (p->double_quotes == PL_DQ_ATOM) { return (pl_parse_term){.term = make_atom(p, s), .prec = 0}; } const size_t n = strlen(s); if (!n) { return (pl_parse_term){.term = make_atom(p, "[]"), .prec = 0}; } if (p->double_quotes == PL_DQ_CODES) { // ISO: `double_quotes` is syntactic only. For codes, build an integer list. pl_term *tail = make_atom(p, "[]"); for (size_t i = n; i > 0; i--) { pl_term *cons = make_struct(p, ".", 2); cons->v.str.args[0] = make_int(p, (SLO)(unsigned char)s[i - 1]); cons->v.str.args[1] = tail; tail = cons; } return (pl_parse_term){.term = tail, .prec = 0}; } // chars => packed list-of-chars pl_term *nil = make_atom(p, "[]"); pl_term *ps = make_pstr(p, (const unsigned char *)s, (ULO)n, nil); if (!ps) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", p->dbg_dat_ptr); } return (pl_parse_term){.term = ps, .prec = 0}; } if (t.type == TOK_INT) { return (pl_parse_term){.term = make_int_from_tok(p, t), .prec = 0}; } if (t.type == TOK_FLOAT) { return (pl_parse_term){.term = make_float(p, t.fval), .prec = 0}; } if (t.type == TOK_VAR) { if (!allow_vars) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: variables not supported in facts (yet)", p->dbg_dat_ptr); } CHR *name = tok_to_cstr(p, t); ULO id = var_table_intern(p, vt, name); return (pl_parse_term){.term = make_var(p, scope, id, name), .prec = 0}; } if (t.type == TOK_LBRACK) { return (pl_parse_term){.term = parse_list(p, vt, scope, allow_vars), .prec = 0}; } rise_unexpected_token_term(p, t, allow_vars); return (pl_parse_term){0}; } static pl_parse_term parse_term_op(pl_parse *p, pl_var_table *vt, const pl_scope *scope, bool allow_vars, int max_prec) { if (max_prec < 0) { max_prec = 0; } pl_tok t0 = peek_tok(p); const pl_op_decl *pre = lookup_prefix_op(p->ops, &p->lx, t0); if (pre && (pre->prec <= max_prec) && (t0.type == TOK_ATOM)) { // Disambiguate prefix-operator vs functor-call syntax when followed by '('. // // Match common Prolog behavior (e.g. Trealla): // \+(...) => functor call \+/1 (arguments parsed at precedence 999) // \+ (...) => prefix operator \+/1 applied to a grouped goal/term // // This matters for control constructs such as `\+ (A -> B)` where `->/2` // has precedence 1050 and cannot appear inside a functor argument list // without extra parentheses. pl_parse snap = *p; const pl_tok op_tok = take_tok(&snap); const pl_tok next = peek_tok(&snap); if (next.type == TOK_LPAREN) { const CHR *op_end = op_tok.start ? (op_tok.start + op_tok.len) : NULL; const bool adjacent = (op_end && next.start && (op_end == next.start)); if (adjacent) { pre = NULL; } } } pl_parse_term left = {0}; if (pre && (pre->prec <= max_prec)) { (void)take_tok(p); const int arg_prec = (pre->fix == PL_OP_PREFIX_FX) ? (pre->prec - 1) : pre->prec; pl_parse_term arg = parse_term_op(p, vt, scope, allow_vars, arg_prec); // Fold unary +/- onto numeric literals so '-2' is parsed as the integer -2 // (and not the term -(2)). if (arg.term && (!strcmp(pre->name, "+") || !strcmp(pre->name, "-"))) { if (arg.term->tag == PL_TERM_INT) { const SLO v = arg.term->v.int_value; left.term = make_int(p, !strcmp(pre->name, "-") ? -v : v); } else if (arg.term->tag == PL_TERM_BIGINT) { if (!strcmp(pre->name, "-")) { pl_bigint *neg = bigint_negate(arg.term->v.bigint, p->rt_ctrl, p->dbg_dat_ptr); left.term = make_bigint(p, neg); } else { left.term = arg.term; } } else if (arg.term->tag == PL_TERM_FLOAT) { const double v = arg.term->v.float_value; left.term = make_float(p, !strcmp(pre->name, "-") ? -v : v); } else { pl_term *st = make_struct(p, pre->name, 1); st->v.str.args[0] = arg.term; left.term = st; } } else { pl_term *st = make_struct(p, pre->name, 1); st->v.str.args[0] = arg.term; left.term = st; } left.prec = pre->prec; } else { left = parse_primary_op(p, vt, scope, allow_vars); } for (;;) { pl_tok t1 = peek_tok(p); const pl_op_decl *post = lookup_postfix_op(p->ops, &p->lx, t1); if (post && (post->prec <= max_prec)) { bool left_ok = (post->fix == PL_OP_POSTFIX_YF) ? (left.prec <= post->prec) : (left.prec < post->prec); if (left_ok) { (void)take_tok(p); pl_term *st = make_struct(p, post->name, 1); st->v.str.args[0] = left.term; left.term = st; left.prec = post->prec; continue; } } const pl_op_decl *in = lookup_infix_op(p->ops, &p->lx, t1); if (!in || (in->prec > max_prec)) { break; } bool left_ok = false; switch (in->fix) { case PL_OP_INFIX_XFX: case PL_OP_INFIX_XFY: left_ok = (left.prec < in->prec); break; case PL_OP_INFIX_YFX: left_ok = (left.prec <= in->prec); break; default: left_ok = false; break; } if (!left_ok) { break; } (void)take_tok(p); int right_max = in->prec; if (in->fix == PL_OP_INFIX_XFX || in->fix == PL_OP_INFIX_YFX) { right_max = in->prec - 1; } pl_parse_term right = parse_term_op(p, vt, scope, allow_vars, right_max); pl_term *st = make_struct(p, in->name, 2); st->v.str.args[0] = left.term; st->v.str.args[1] = right.term; left.term = st; left.prec = in->prec; } return left; } static pl_term *parse_term(pl_parse *p, pl_var_table *vt, const pl_scope *scope, bool allow_vars, int max_prec) { return parse_term_op(p, vt, scope, allow_vars, max_prec).term; } static void goals_append(pl_parse *p, pl_term *g, pl_term ***goals, ULO *count, ULO *cap) { if (*count == *cap) { ULO new_cap = *cap ? (*cap * 2) : 4; pl_term **new_goals = (pl_term **)pool_alloc(p->rt_ctrl, sizeof(pl_term *) * new_cap, p->dbg_dat_ptr); if (*goals && *count) { memcpy(new_goals, *goals, sizeof(pl_term *) * (*count)); } *goals = new_goals; *cap = new_cap; } (*goals)[(*count)++] = g; } static void flatten_conjunction_goals(pl_parse *p, pl_term *t, pl_term ***goals, ULO *count, ULO *cap) { if (t && (t->tag == PL_TERM_STRUCT) && (t->v.str.arity == 2) && !strcmp(t->v.str.functor, ",")) { flatten_conjunction_goals(p, t->v.str.args[0], goals, count, cap); flatten_conjunction_goals(p, t->v.str.args[1], goals, count, cap); return; } goals_append(p, t, goals, count, cap); } static bool term_equal(const pl_term *a, const pl_term *b); static bool term_identical_env(const pl_term *a, const pl_term *b, const pl_env *env); /* ============================================================================ * SECTION 11: Packed Strings & List-Like Helpers * packed-string layout helpers and list-equivalent operations. * ============================================================================ */ /* --- SUBSECTION 11.1: Packed-String Layout Helpers ----------------------- */ // Packed-string layout helpers for UTF-8 runs and tail pointers. // pstr_tail_term_from_nul() resolves tails; pstr_run_len_bytes()/pstr_run_len_codepoints() and pstr_decode_one() walk runs. static inline pl_term *pstr_tail_term_from_nul(const unsigned char *nul) { if (!nul) { return NULL; } const unsigned char *p = nul + 1; // skip NUL terminator const uintptr_t align = (uintptr_t)sizeof(void *); uintptr_t addr = (uintptr_t)p; addr = (addr + align - 1) & ~(align - 1); return *(pl_term **)addr; } static inline pl_term **pstr_tail_slot_from_nul(unsigned char *nul) { if (!nul) { return NULL; } unsigned char *p = nul + 1; const uintptr_t align = (uintptr_t)sizeof(void *); uintptr_t addr = (uintptr_t)p; addr = (addr + align - 1) & ~(align - 1); return (pl_term **)addr; } static inline size_t pstr_run_len_bytes(const unsigned char *bytes) { return bytes ? strlen((const char *)bytes) : 0; } static inline ULO pstr_run_len_codepoints(const unsigned char *bytes) { if (!bytes) { return 0; } const size_t len = pstr_run_len_bytes(bytes); return utf8_count_codepoints_lenient(bytes, (ULO)len); } static inline size_t pstr_run_utf8_len(const unsigned char *bytes) { return pstr_run_len_bytes(bytes); } static inline size_t pstr_run_utf8_copy(const unsigned char *bytes, unsigned char *dst, size_t cap) { if (!bytes || !dst) { return 0; } size_t len = pstr_run_len_bytes(bytes); if (len > cap) { len = cap; } memcpy(dst, bytes, len); return len; } static inline pl_term *pstr_tail_term_from_bytes(const unsigned char *bytes) { if (!bytes) { return NULL; } const size_t len = pstr_run_len_bytes(bytes); return pstr_tail_term_from_nul(bytes + len); } static inline size_t pstr_decode_one(const unsigned char *bytes, uint32_t *out_cp) { if (!bytes || !*bytes || !out_cp) { return 0; } size_t avail = 0; while (avail < PL_UTF8_MAX_BYTES && bytes[avail] != 0) { avail++; } if (!avail) { return 0; } return utf8_decode_one_lenient(bytes, avail, out_cp); } static inline uint32_t *pstr_decode_run_codepoints(const unsigned char *bytes, size_t len_bytes, ULO *out_len, const ULO *dbg_dat_ptr) { if (!bytes || !out_len) { return NULL; } const ULO cp_len = utf8_count_codepoints_lenient(bytes, (ULO)len_bytes); if (!cp_len) { *out_len = 0; return NULL; } uint32_t *buf = (uint32_t *)malloc(sizeof(uint32_t) * (size_t)cp_len); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); return NULL; } (void)utf8_decode_into(bytes, (ULO)len_bytes, buf, cp_len); *out_len = cp_len; return buf; } static inline pl_term *pstr_tail_term(const pl_term *t) { if (!t || t->tag != PL_TERM_PSTR) { return NULL; } return pstr_tail_term_from_bytes(t->v.pstr.bytes); } /* --- SUBSECTION 11.2: Packed-String Equality ---------------------------- */ // Packed-string equality with list semantics. // pstr_terms_equal_with_tail() walks runs and tails, using pstr_tail_eq_term_equal() or pstr_tail_eq_term_identical() for tail comparison. typedef bool (*pstr_tail_eq_fn)(const pl_term *a, const pl_term *b, const void *ctx); static inline bool pstr_tail_eq_term_equal(const pl_term *a, const pl_term *b, const void *ctx) { (void)ctx; return term_equal(a, b); } static inline bool pstr_tail_eq_term_identical(const pl_term *a, const pl_term *b, const void *ctx) { return term_identical_env(a, b, (const pl_env *)ctx); } static inline bool pstr_terms_equal_with_tail(const pl_term *a, const pl_term *b, pstr_tail_eq_fn tail_eq, const void *ctx) { if (!a || !b || a->tag != PL_TERM_PSTR || b->tag != PL_TERM_PSTR) { return false; } if (!tail_eq) { return false; } const unsigned char *ap = a->v.pstr.bytes; const unsigned char *bp = b->v.pstr.bytes; if (!ap || !bp) { return false; } // Treat PSTR as list-equivalent: compare codepoints, then compare tails. for (ULO guard = 0; guard < 65536; guard++) { if ((*ap == 0) || (*bp == 0)) { if (*ap == 0 && *bp == 0) { pl_term *atail = pstr_tail_term_from_nul(ap); pl_term *btail = pstr_tail_term_from_nul(bp); if (!atail || !btail) { return false; } if (atail->tag == PL_TERM_PSTR && btail->tag == PL_TERM_PSTR && atail->v.pstr.bytes && btail->v.pstr.bytes) { ap = atail->v.pstr.bytes; bp = btail->v.pstr.bytes; continue; } return tail_eq(atail, btail, ctx); } if (*ap == 0) { pl_term *atail = pstr_tail_term_from_nul(ap); if (!atail) { return false; } pl_term b_rem = {0}; b_rem.tag = PL_TERM_PSTR; b_rem.v.pstr.bytes = bp; return tail_eq(atail, &b_rem, ctx); } pl_term *btail = pstr_tail_term_from_nul(bp); if (!btail) { return false; } pl_term a_rem = {0}; a_rem.tag = PL_TERM_PSTR; a_rem.v.pstr.bytes = ap; return tail_eq(&a_rem, btail, ctx); } uint32_t acp = 0; uint32_t bcp = 0; const size_t aused = pstr_decode_one(ap, &acp); const size_t bused = pstr_decode_one(bp, &bcp); if (!aused || !bused || (acp != bcp)) { return false; } ap += aused; bp += bused; } return false; } static inline bool pstr_terms_equal(const pl_term *a, const pl_term *b) { return pstr_terms_equal_with_tail(a, b, pstr_tail_eq_term_equal, NULL); } static bool term_is_list_pair(const pl_term *t); static bool term_is_list_like_pair(const pl_term *t); static bool term_is_nil(const pl_term *t); static bool term_is_pstr_nonempty(const pl_term *t); static bool term_list_like_uncons_rt(pl_term *t, pl_term **out_head, pl_term **out_tail, const void *rt_ctrl, const ULO *dbg_dat_ptr); static inline const pl_term *pstr_empty_next_const(const pl_term *t) { if (!t || t->tag != PL_TERM_PSTR) { return NULL; } const unsigned char *bytes = t->v.pstr.bytes; if (!bytes || bytes[0] != 0) { return NULL; } return pstr_tail_term_from_nul(bytes); } static inline const pl_term *term_peel_pstr_empty_const(const pl_term *t) { const pl_term *cur = t; const pl_term *slow = t; const pl_term *fast = t; while (1) { if (!cur || cur->tag != PL_TERM_PSTR) { return cur; } const unsigned char *bytes = cur->v.pstr.bytes; if (!bytes) { return cur; } if (bytes[0] != 0) { return cur; } pl_term *tail = pstr_tail_term_from_nul(bytes); if (!tail) { return cur; } cur = tail; slow = pstr_empty_next_const(slow); fast = pstr_empty_next_const(fast); if (fast) { fast = pstr_empty_next_const(fast); } if (slow && fast && slow == fast) { return cur; } } } /* --- SUBSECTION 11.3: List-Like View Helpers ---------------------------- */ // List-like view helpers for lists and packed strings. // term_list_like_uncons_view()/term_list_like_uncons_rt() expose head/tail; term_pstr_run_len_and_tail_peeled_const() and term_pstr_run_bytes_len_tail_const() accelerate traversal. static bool term_list_like_uncons_view(const pl_term *t, const pl_term **out_head, const pl_term **out_tail, pl_term *tmp_head, CHR tmp_head_ch[PL_UTF8_MAX_BYTES + 1], pl_term *tmp_tail) { if (!out_head || !out_tail) { return false; } *out_head = NULL; *out_tail = NULL; t = term_peel_pstr_empty_const(t); if (!t) { return false; } if (term_is_list_pair(t)) { *out_head = t->v.str.args[0]; *out_tail = t->v.str.args[1]; return true; } if (t->tag != PL_TERM_PSTR || !t->v.pstr.bytes || t->v.pstr.bytes[0] == 0) { return false; } const unsigned char *bytes = t->v.pstr.bytes; if (!tmp_head || !tmp_head_ch) { return false; } memset(tmp_head, 0, sizeof(*tmp_head)); uint32_t head_cp = 0; const size_t used = pstr_decode_one(bytes, &head_cp); if (!used) { return false; } const size_t head_len = utf8_encode_one(head_cp, (unsigned char *)tmp_head_ch, PL_UTF8_MAX_BYTES); tmp_head_ch[head_len] = 0; tmp_head->tag = PL_TERM_ATOM; tmp_head->v.atom_name = tmp_head_ch; *out_head = tmp_head; if (bytes[used] != 0) { if (!tmp_tail) { return false; } memset(tmp_tail, 0, sizeof(*tmp_tail)); tmp_tail->tag = PL_TERM_PSTR; tmp_tail->v.pstr.bytes = bytes + used; *out_tail = tmp_tail; return true; } pl_term *tail = pstr_tail_term_from_nul(bytes + used); if (!tail) { return false; } *out_tail = tail; return true; } static bool term_list_like_run_len_and_tail_const(const pl_term *t, ULO *out_run_len, const pl_term **out_tail) { if (!out_run_len || !out_tail) { return false; } *out_run_len = 0; *out_tail = NULL; t = term_peel_pstr_empty_const(t); if (!t) { return false; } if (term_is_list_pair(t)) { *out_run_len = 1; *out_tail = t->v.str.args[1]; return true; } if (t->tag != PL_TERM_PSTR || !t->v.pstr.bytes || t->v.pstr.bytes[0] == 0) { return false; } const unsigned char *bytes = t->v.pstr.bytes; const ULO len = pstr_run_len_codepoints(bytes); pl_term *tail = pstr_tail_term_from_bytes(bytes); if (!tail) { return false; } *out_run_len = len; *out_tail = tail; return true; } static inline bool term_pstr_run_len_and_tail_peeled_const(const pl_term *t, ULO *out_run_len, const pl_term **out_tail) { if (!t || !out_run_len || !out_tail) { return false; } if (t->tag != PL_TERM_PSTR || !t->v.pstr.bytes || t->v.pstr.bytes[0] == 0) { return false; } const unsigned char *bytes = t->v.pstr.bytes; const ULO len = pstr_run_len_codepoints(bytes); pl_term *tail = pstr_tail_term_from_bytes(bytes); if (!tail) { return false; } *out_run_len = len; *out_tail = tail; return true; } static bool term_pstr_run_bytes_len_tail_const(const pl_term *t, const unsigned char **out_bytes, ULO *out_len, const pl_term **out_tail) { if (!out_bytes || !out_len || !out_tail) { return false; } *out_bytes = NULL; *out_len = 0; *out_tail = NULL; t = term_peel_pstr_empty_const(t); if (!t || t->tag != PL_TERM_PSTR || !t->v.pstr.bytes || t->v.pstr.bytes[0] == 0) { return false; } const unsigned char *bytes = t->v.pstr.bytes; const size_t len_bytes = pstr_run_len_bytes(bytes); *out_bytes = bytes; *out_len = (ULO)len_bytes; *out_tail = pstr_tail_term_from_nul(bytes + len_bytes); return true; } typedef enum { PL_PSTR_CSTR_FALLBACK = 0, PL_PSTR_CSTR_OK_BORROWED, PL_PSTR_CSTR_OK_OWNED, PL_PSTR_CSTR_INSTANTIATION, } pl_pstr_cstr_status; static bool pstr_cstr_status_ok(pl_pstr_cstr_status pst) { return (pst == PL_PSTR_CSTR_OK_BORROWED) || (pst == PL_PSTR_CSTR_OK_OWNED); } static pl_pstr_cstr_status pstr_list_to_cstr_env(pl_term *list, const pl_env *env, const unsigned char **out_cstr, ULO *out_len, unsigned char **out_buf, const ULO *dbg_dat_ptr) { if (!out_cstr || !out_len || !out_buf) { return PL_PSTR_CSTR_FALLBACK; } *out_cstr = NULL; *out_len = 0; *out_buf = NULL; if (!list) { return PL_PSTR_CSTR_FALLBACK; } pl_term *cur = deref_term(list, env); cur = (pl_term *)term_peel_pstr_empty_const(cur); if (!cur) { return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(cur)) { static const unsigned char empty[1] = {0}; *out_cstr = empty; *out_len = 0; return PL_PSTR_CSTR_OK_BORROWED; } if (cur->tag == PL_TERM_VAR) { return PL_PSTR_CSTR_INSTANTIATION; } if (cur->tag != PL_TERM_PSTR || !cur->v.pstr.bytes) { return PL_PSTR_CSTR_FALLBACK; } const unsigned char *bytes0 = cur->v.pstr.bytes; const size_t len0 = pstr_run_len_bytes(bytes0); pl_term *tail0 = pstr_tail_term_from_nul(bytes0 + len0); if (!tail0) { return PL_PSTR_CSTR_FALLBACK; } pl_term *tail = deref_term(tail0, env); tail = (pl_term *)term_peel_pstr_empty_const(tail); if (!tail) { return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(tail)) { const size_t total = pstr_run_utf8_len(bytes0); unsigned char *buf = (unsigned char *)malloc(total + 1); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } const size_t off = pstr_run_utf8_copy(bytes0, buf, total); buf[off] = 0; *out_cstr = buf; *out_len = (ULO)off; *out_buf = buf; return PL_PSTR_CSTR_OK_OWNED; } if (tail->tag == PL_TERM_VAR) { return PL_PSTR_CSTR_INSTANTIATION; } if (tail->tag != PL_TERM_PSTR || !tail->v.pstr.bytes) { return PL_PSTR_CSTR_FALLBACK; } // Multi-segment packed string: compute total size, then copy. size_t total = pstr_run_utf8_len(bytes0); pl_term *seg = tail; for (ULO guard = 0; guard < 65536; guard++) { if (!seg) { return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(seg)) { break; } if (seg->tag == PL_TERM_VAR) { return PL_PSTR_CSTR_INSTANTIATION; } if (seg->tag != PL_TERM_PSTR || !seg->v.pstr.bytes) { return PL_PSTR_CSTR_FALLBACK; } const unsigned char *b = seg->v.pstr.bytes; const size_t l = pstr_run_len_bytes(b); total += pstr_run_utf8_len(b); pl_term *next = pstr_tail_term_from_nul(b + l); if (!next) { return PL_PSTR_CSTR_FALLBACK; } seg = deref_term(next, env); seg = (pl_term *)term_peel_pstr_empty_const(seg); } unsigned char *buf = (unsigned char *)malloc(total + 1); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; off += pstr_run_utf8_copy(bytes0, buf + off, total - off); seg = tail; for (ULO guard = 0; guard < 65536; guard++) { if (!seg) { free(buf); return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(seg)) { break; } if (seg->tag != PL_TERM_PSTR || !seg->v.pstr.bytes) { free(buf); return PL_PSTR_CSTR_FALLBACK; } const unsigned char *b = seg->v.pstr.bytes; const size_t l = pstr_run_len_bytes(b); off += pstr_run_utf8_copy(b, buf + off, total - off); pl_term *next = pstr_tail_term_from_nul(b + l); if (!next) { free(buf); return PL_PSTR_CSTR_FALLBACK; } seg = deref_term(next, env); seg = (pl_term *)term_peel_pstr_empty_const(seg); } buf[off] = 0; *out_cstr = buf; *out_len = (ULO)off; *out_buf = buf; return PL_PSTR_CSTR_OK_OWNED; } static pl_pstr_cstr_status pstr_list_to_cstr_wam(pl_term *list, const unsigned char **out_cstr, ULO *out_len, unsigned char **out_buf, const ULO *dbg_dat_ptr) { if (!out_cstr || !out_len || !out_buf) { return PL_PSTR_CSTR_FALLBACK; } *out_cstr = NULL; *out_len = 0; *out_buf = NULL; if (!list) { return PL_PSTR_CSTR_FALLBACK; } pl_term *cur = deref_term_wam(list); cur = (pl_term *)term_peel_pstr_empty_const(cur); if (!cur) { return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(cur)) { static const unsigned char empty[1] = {0}; *out_cstr = empty; *out_len = 0; return PL_PSTR_CSTR_OK_BORROWED; } if (cur->tag == PL_TERM_VAR) { return PL_PSTR_CSTR_INSTANTIATION; } if (cur->tag != PL_TERM_PSTR || !cur->v.pstr.bytes) { return PL_PSTR_CSTR_FALLBACK; } const unsigned char *bytes0 = cur->v.pstr.bytes; const size_t len0 = pstr_run_len_bytes(bytes0); pl_term *tail0 = pstr_tail_term_from_nul(bytes0 + len0); if (!tail0) { return PL_PSTR_CSTR_FALLBACK; } pl_term *tail = deref_term_wam(tail0); tail = (pl_term *)term_peel_pstr_empty_const(tail); if (!tail) { return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(tail)) { const size_t total = pstr_run_utf8_len(bytes0); unsigned char *buf = (unsigned char *)malloc(total + 1); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } const size_t off = pstr_run_utf8_copy(bytes0, buf, total); buf[off] = 0; *out_cstr = buf; *out_len = (ULO)off; *out_buf = buf; return PL_PSTR_CSTR_OK_OWNED; } if (tail->tag == PL_TERM_VAR) { return PL_PSTR_CSTR_INSTANTIATION; } if (tail->tag != PL_TERM_PSTR || !tail->v.pstr.bytes) { return PL_PSTR_CSTR_FALLBACK; } size_t total = pstr_run_utf8_len(bytes0); pl_term *seg = tail; for (ULO guard = 0; guard < 65536; guard++) { if (!seg) { return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(seg)) { break; } if (seg->tag == PL_TERM_VAR) { return PL_PSTR_CSTR_INSTANTIATION; } if (seg->tag != PL_TERM_PSTR || !seg->v.pstr.bytes) { return PL_PSTR_CSTR_FALLBACK; } const unsigned char *b = seg->v.pstr.bytes; const size_t l = pstr_run_len_bytes(b); total += pstr_run_utf8_len(b); pl_term *next = pstr_tail_term_from_nul(b + l); if (!next) { return PL_PSTR_CSTR_FALLBACK; } seg = deref_term_wam(next); seg = (pl_term *)term_peel_pstr_empty_const(seg); } unsigned char *buf = (unsigned char *)malloc(total + 1); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; off += pstr_run_utf8_copy(bytes0, buf + off, total - off); seg = tail; for (ULO guard = 0; guard < 65536; guard++) { if (!seg) { free(buf); return PL_PSTR_CSTR_FALLBACK; } if (term_is_nil(seg)) { break; } if (seg->tag != PL_TERM_PSTR || !seg->v.pstr.bytes) { free(buf); return PL_PSTR_CSTR_FALLBACK; } const unsigned char *b = seg->v.pstr.bytes; const size_t l = pstr_run_len_bytes(b); off += pstr_run_utf8_copy(b, buf + off, total - off); pl_term *next = pstr_tail_term_from_nul(b + l); if (!next) { free(buf); return PL_PSTR_CSTR_FALLBACK; } seg = deref_term_wam(next); seg = (pl_term *)term_peel_pstr_empty_const(seg); } buf[off] = 0; *out_cstr = buf; *out_len = (ULO)off; *out_buf = buf; return PL_PSTR_CSTR_OK_OWNED; } typedef enum { FLOWLOG_FILE_CHARS_OK = 0, FLOWLOG_FILE_CHARS_ERR_OPEN, FLOWLOG_FILE_CHARS_ERR_IO, FLOWLOG_FILE_CHARS_ERR_INVALID, FLOWLOG_FILE_CHARS_ERR_TOO_LARGE, } flowlog_file_chars_status; typedef enum { FLOWLOG_FILE_BYTES_OK = 0, FLOWLOG_FILE_BYTES_ERR_OPEN, FLOWLOG_FILE_BYTES_ERR_IO, FLOWLOG_FILE_BYTES_ERR_TOO_LARGE, } flowlog_file_bytes_status; static CHR *flowlog_read_fd_all(int fd, size_t *out_len) { if (out_len) { *out_len = 0; } if (fd < 0) { return NULL; } CHR *buf = NULL; size_t cap = 0; size_t len = 0; for (;;) { if (len + 8192 + 1 > cap) { size_t new_cap = cap ? cap * 2 : 65536; while (new_cap < len + 8192 + 1) { new_cap *= 2; } CHR *nb = (CHR *)realloc(buf, new_cap); if (!nb) { free(buf); return NULL; } buf = nb; cap = new_cap; } ssize_t n = read(fd, buf + len, 8192); if (n == 0) { break; } if (n < 0) { if (errno == EINTR) { continue; } free(buf); return NULL; } len += (size_t)n; } if (!buf) { buf = (CHR *)malloc(1); if (!buf) { return NULL; } buf[0] = '\0'; } else { buf[len] = '\0'; } if (out_len) { *out_len = len; } return buf; } /* --- SUBSECTION 11.4: File-to-List Helpers ------------------------------ */ // File-to-list helpers for UTF-8 chars and raw bytes. // flowlog_file_to_chars_term() mmaps or copies into packed strings; flowlog_file_to_bytes_term() builds byte lists via flowlog_bytes_to_list_rt(); pstr_map_len_for_bytes() sizes mmap. static pl_term *flowlog_bytes_to_list_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const unsigned char *buf, size_t len) { pl_term *tail = make_nil_rt(dbg_dat_ptr); if (!buf || !len) { return tail; } for (size_t i = len; i-- > 0;) { pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)buf[i]); cons->v.str.args[1] = tail; tail = cons; } return tail; } static bool pstr_map_len_for_bytes(size_t len, size_t *out_len) { if (!out_len) { return false; } const size_t align = sizeof(void *); size_t off = len + 1; if (off < len) { return false; } size_t aligned = (off + align - 1) & ~(align - 1); if (aligned < off) { return false; } size_t total = aligned + sizeof(pl_term *); if (total < aligned) { return false; } *out_len = total; return true; } static flowlog_file_chars_status flowlog_pstr_from_bytes_copy(const unsigned char *buf, size_t len, const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term **out_term) { if (out_term) { *out_term = NULL; } if (!buf && len) { return FLOWLOG_FILE_CHARS_ERR_INVALID; } pl_term *tail = make_nil_rt(dbg_dat_ptr); size_t seg_end = len; for (size_t i = len; i-- > 0;) { if (buf[i] != 0) { continue; } const size_t seg_start = i + 1; if (seg_start < seg_end) { const size_t seg_len = seg_end - seg_start; if (!utf8_validate_no_nul(buf + seg_start, seg_len)) { return FLOWLOG_FILE_CHARS_ERR_INVALID; } tail = make_pstr_bytes_alloc(rt_ctrl, dbg_dat_ptr, buf + seg_start, (ULO)seg_len, tail); } pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, 0); cons->v.str.args[1] = tail; tail = cons; seg_end = i; } if (seg_end > 0) { if (!utf8_validate_no_nul(buf, seg_end)) { return FLOWLOG_FILE_CHARS_ERR_INVALID; } tail = make_pstr_bytes_alloc(rt_ctrl, dbg_dat_ptr, buf, (ULO)seg_end, tail); } if (out_term) { *out_term = tail; } return FLOWLOG_FILE_CHARS_OK; } static flowlog_file_chars_status flowlog_file_to_chars_term(const char *path, const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term **out_term, int *out_errno) { if (out_term) { *out_term = NULL; } if (out_errno) { *out_errno = 0; } if (!path || !*path) { return FLOWLOG_FILE_CHARS_ERR_OPEN; } int fd = open(path, O_RDONLY); if (fd < 0) { if (out_errno) { *out_errno = errno; } return FLOWLOG_FILE_CHARS_ERR_OPEN; } struct stat st; if (fstat(fd, &st) != 0) { if (out_errno) { *out_errno = errno; } (void)close(fd); return FLOWLOG_FILE_CHARS_ERR_IO; } if (S_ISREG(st.st_mode)) { if (st.st_size < 0) { (void)close(fd); return FLOWLOG_FILE_CHARS_ERR_TOO_LARGE; } const unsigned long long sz = (unsigned long long)st.st_size; if (sz > (unsigned long long)SIZE_MAX || sz > (unsigned long long)ULONG_MAX) { (void)close(fd); return FLOWLOG_FILE_CHARS_ERR_TOO_LARGE; } if (sz == 0) { (void)close(fd); if (out_term) { *out_term = make_nil_rt(dbg_dat_ptr); } return FLOWLOG_FILE_CHARS_OK; } size_t map_len = 0; if (!pstr_map_len_for_bytes((size_t)sz, &map_len)) { (void)close(fd); return FLOWLOG_FILE_CHARS_ERR_TOO_LARGE; } void *map = mmap(NULL, map_len, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0); if (map != MAP_FAILED) { void *file_map = mmap(map, (size_t)sz, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_FIXED, fd, 0); if (file_map != MAP_FAILED) { (void)close(fd); const unsigned char *src = (const unsigned char *)map; if (utf8_validate_no_nul(src, (size_t)sz)) { unsigned char *nul = (unsigned char *)src + (size_t)sz; *nul = 0; pl_term **tail_slot = pstr_tail_slot_from_nul(nul); if (!tail_slot) { (void)munmap(map, map_len); return FLOWLOG_FILE_CHARS_ERR_INVALID; } *tail_slot = make_nil_rt(dbg_dat_ptr); if (out_term) { *out_term = make_pstr_bytes_ref(rt_ctrl, dbg_dat_ptr, src); } return FLOWLOG_FILE_CHARS_OK; } const flowlog_file_chars_status status = flowlog_pstr_from_bytes_copy(src, (size_t)sz, rt_ctrl, dbg_dat_ptr, out_term); (void)munmap(map, map_len); return status; } (void)munmap(map, map_len); } } size_t len = 0; CHR *buf = flowlog_read_fd_all(fd, &len); const int saved_errno = errno; (void)close(fd); if (!buf) { if (out_errno) { *out_errno = saved_errno; } return FLOWLOG_FILE_CHARS_ERR_IO; } if (len > (size_t)ULONG_MAX) { free(buf); return FLOWLOG_FILE_CHARS_ERR_TOO_LARGE; } if (len == 0) { free(buf); if (out_term) { *out_term = make_nil_rt(dbg_dat_ptr); } return FLOWLOG_FILE_CHARS_OK; } const flowlog_file_chars_status status = flowlog_pstr_from_bytes_copy((const unsigned char *)buf, len, rt_ctrl, dbg_dat_ptr, out_term); free(buf); return status; } static flowlog_file_bytes_status flowlog_file_to_bytes_term(const char *path, const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term **out_term, int *out_errno) { if (out_term) { *out_term = NULL; } if (out_errno) { *out_errno = 0; } if (!path || !*path) { return FLOWLOG_FILE_BYTES_ERR_OPEN; } int fd = open(path, O_RDONLY); if (fd < 0) { if (out_errno) { *out_errno = errno; } return FLOWLOG_FILE_BYTES_ERR_OPEN; } struct stat st; if (fstat(fd, &st) != 0) { if (out_errno) { *out_errno = errno; } (void)close(fd); return FLOWLOG_FILE_BYTES_ERR_IO; } if (S_ISREG(st.st_mode)) { if (st.st_size < 0) { (void)close(fd); return FLOWLOG_FILE_BYTES_ERR_TOO_LARGE; } const unsigned long long sz = (unsigned long long)st.st_size; if (sz > (unsigned long long)SIZE_MAX || sz > (unsigned long long)ULONG_MAX) { (void)close(fd); return FLOWLOG_FILE_BYTES_ERR_TOO_LARGE; } if (sz == 0) { (void)close(fd); if (out_term) { *out_term = make_nil_rt(dbg_dat_ptr); } return FLOWLOG_FILE_BYTES_OK; } void *map = mmap(NULL, (size_t)sz, PROT_READ, MAP_PRIVATE, fd, 0); if (map != MAP_FAILED) { (void)close(fd); pl_term *t = flowlog_bytes_to_list_rt(rt_ctrl, dbg_dat_ptr, (const unsigned char *)map, (size_t)sz); (void)munmap(map, (size_t)sz); if (out_term) { *out_term = t; } return FLOWLOG_FILE_BYTES_OK; } } size_t len = 0; CHR *buf = flowlog_read_fd_all(fd, &len); const int saved_errno = errno; (void)close(fd); if (!buf) { if (out_errno) { *out_errno = saved_errno; } return FLOWLOG_FILE_BYTES_ERR_IO; } if (len > (size_t)ULONG_MAX) { free(buf); return FLOWLOG_FILE_BYTES_ERR_TOO_LARGE; } pl_term *t = flowlog_bytes_to_list_rt(rt_ctrl, dbg_dat_ptr, (const unsigned char *)buf, len); free(buf); if (out_term) { *out_term = t; } return FLOWLOG_FILE_BYTES_OK; } /* ============================================================================ * SECTION 12: Term Equality & List Helpers * list-equivalent equality and structural term comparison helpers. * ============================================================================ */ /* --- SUBSECTION 12.1: List-Like Equality --------------------------------- */ // List-like equality for lists and packed strings. // term_equal_list_like() peels empty packed runs and compares heads/tails with packed-string fast paths. static bool term_equal_list_like(const pl_term *a, const pl_term *b) { a = term_peel_pstr_empty_const(a); b = term_peel_pstr_empty_const(b); if (!a || !b) { return a == b; } // Fast path for packed strings. if (a->tag == PL_TERM_PSTR && b->tag == PL_TERM_PSTR) { return pstr_terms_equal(a, b); } const pl_term *ah = NULL; const pl_term *at = NULL; const pl_term *bh = NULL; const pl_term *bt = NULL; pl_term a_head_tmp = {0}; CHR a_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term a_tail_tmp = {0}; pl_term b_head_tmp = {0}; CHR b_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term b_tail_tmp = {0}; if (!term_list_like_uncons_view(a, &ah, &at, &a_head_tmp, a_head_ch, &a_tail_tmp) || !term_list_like_uncons_view(b, &bh, &bt, &b_head_tmp, b_head_ch, &b_tail_tmp)) { return false; } return term_equal(ah, bh) && term_equal(at, bt); } /* --- SUBSECTION 12.2: Structural Equality ------------------------------- */ // Structural equality, identity, and variant checks. // term_equal() and term_identical_env() walk terms with list-like awareness and packed-string tail handling. static bool term_equal(const pl_term *a, const pl_term *b) { if (!a || !b) { return a == b; } a = term_peel_pstr_empty_const(a); b = term_peel_pstr_empty_const(b); if (term_is_list_like_pair(a) || term_is_list_like_pair(b)) { return term_equal_list_like(a, b); } if (term_is_integer(a) || term_is_integer(b)) { return term_is_integer(a) && term_is_integer(b) && term_integer_equal(a, b); } if (a->tag != b->tag) { return false; } switch (a->tag) { case PL_TERM_ATOM: return !strcmp(a->v.atom_name, b->v.atom_name); case PL_TERM_INT: return a->v.int_value == b->v.int_value; case PL_TERM_BIGINT: return term_integer_equal(a, b); case PL_TERM_FLOAT: return a->v.float_value == b->v.float_value; case PL_TERM_VAR: return (a->v.var.scope == b->v.var.scope) && (a->v.var.var_id == b->v.var.var_id); case PL_TERM_STRUCT: if (a->v.str.arity != b->v.str.arity) { return false; } if (strcmp(a->v.str.functor, b->v.str.functor)) { return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!term_equal(a->v.str.args[i], b->v.str.args[i])) { return false; } } return true; case PL_TERM_PSTR: break; } return false; } /* ============================================================================ * SECTION 13: Program DB & Indexing * predicate storage, indexing, and clause snapshots. * ============================================================================ */ /* --- SUBSECTION 13.1: Predicate Sets ------------------------------------- */ // Predicate sets and term identity helpers. // prog_pred_defined()/builtin_pred_defined() check availability; term_identical_env()/term_identical_pstr_env() compare terms under env bindings. static bool prog_dyn_pred_contains(const pl_program *prog, const CHR *name, ULO arity); static void prog_dyn_pred_add(pl_program *prog, const CHR *name, ULO arity, const void *rt_ctrl, const ULO *dbg_dat_ptr); static void prog_dyn_pred_remove(pl_program *prog, const CHR *name, ULO arity); static bool prog_tabled_pred_contains(const pl_program *prog, const CHR *name, ULO arity); static void prog_tabled_pred_add(pl_program *prog, const CHR *name, ULO arity, const void *rt_ctrl, const ULO *dbg_dat_ptr); static bool prog_pred_defined(const pl_program *prog, const CHR *name, ULO arity, bool *out_dynamic) { if (out_dynamic) { *out_dynamic = false; } if (!prog || !name) { return false; } bool found = false; bool dynamic = false; if (prog->clauses && prog->clause_count) { for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h->tag == PL_TERM_ATOM) { h_name = h->v.atom_name; h_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { h_name = h->v.str.functor; h_arity = h->v.str.arity; } else { continue; } if (!strcmp(h_name, name) && (h_arity == arity)) { found = true; if (cl->env) { dynamic = true; } } } } else if (prog->facts && prog->fact_count) { for (ULO i = 1; i <= prog->fact_count; i++) { const pl_term *h = prog->facts[i]; if (!h) { continue; } const CHR *h_name = NULL; ULO h_arity = 0; if (h->tag == PL_TERM_ATOM) { h_name = h->v.atom_name; h_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { h_name = h->v.str.functor; h_arity = h->v.str.arity; } else { continue; } if (!strcmp(h_name, name) && (h_arity == arity)) { found = true; } } } if (prog_dyn_pred_contains(prog, name, arity)) { found = true; dynamic = true; } if (prog_tabled_pred_contains(prog, name, arity)) { found = true; } if (out_dynamic) { *out_dynamic = dynamic; } return found; } static bool builtin_pred_defined(const CHR *name, ULO arity) { if (!name) { return false; } // Atom goals. if (arity == 0) { if (!strcmp(name, "true") || !strcmp(name, "fail") || !strcmp(name, "false") || !strcmp(name, "!") || !strcmp(name, "repeat") || !strcmp(name, "nl") || !strcmp(name, "flush_output") || !strcmp(name, "at_end_of_stream") || !strcmp(name, "halt") || !strcmp(name, "listing") || !strcmp(name, "trace") || !strcmp(name, "notrace") || !strcmp(name, "itrace") || !strcmp(name, "noitrace") || !strcmp(name, "debug") || !strcmp(name, "nodebug")) { return true; } } // Core built-ins (partial; extended over time). if (!strcmp(name, ",") && arity == 2) return true; if (!strcmp(name, ";") && arity == 2) return true; if (!strcmp(name, "->") && arity == 2) return true; if (!strcmp(name, "\\+") && arity == 1) return true; if (!strcmp(name, "=") && arity == 2) return true; if (!strcmp(name, "\\=") && arity == 2) return true; if (!strcmp(name, "==") && arity == 2) return true; if (!strcmp(name, "\\==") && arity == 2) return true; if (!strcmp(name, "=@=") && arity == 2) return true; if (!strcmp(name, "\\=@=") && arity == 2) return true; if (!strcmp(name, "<") && arity == 2) return true; if (!strcmp(name, "=<") && arity == 2) return true; if (!strcmp(name, ">") && arity == 2) return true; if (!strcmp(name, ">=") && arity == 2) return true; if (!strcmp(name, "=:=") && arity == 2) return true; if (!strcmp(name, "=\\=") && arity == 2) return true; if (!strcmp(name, "@<") && arity == 2) return true; if (!strcmp(name, "@=<") && arity == 2) return true; if (!strcmp(name, "@>") && arity == 2) return true; if (!strcmp(name, "@>=") && arity == 2) return true; if (!strcmp(name, "is") && arity == 2) return true; if (!strcmp(name, "=..") && arity == 2) return true; if (!strcmp(name, "arg") && arity == 3) return true; if (!strcmp(name, "functor") && arity == 3) return true; if (!strcmp(name, "copy_term") && arity == 2) return true; if (!strcmp(name, "term_variables") && arity == 2) return true; if (!strcmp(name, "unify_with_occurs_check") && arity == 2) return true; if (!strcmp(name, "acyclic_term") && arity == 1) return true; if (!strcmp(name, "ground") && arity == 1) return true; if (!strcmp(name, "var") && arity == 1) return true; if (!strcmp(name, "nonvar") && arity == 1) return true; if (!strcmp(name, "atom") && arity == 1) return true; if (!strcmp(name, "integer") && arity == 1) return true; if (!strcmp(name, "float") && arity == 1) return true; if (!strcmp(name, "number") && arity == 1) return true; if (!strcmp(name, "atomic") && arity == 1) return true; if (!strcmp(name, "compound") && arity == 1) return true; if (!strcmp(name, "callable") && arity == 1) return true; if (!strcmp(name, "compare") && arity == 3) return true; if (!strcmp(name, "atom_chars") && arity == 2) return true; if (!strcmp(name, "atom_codes") && arity == 2) return true; if (!strcmp(name, "atom_concat") && arity == 3) return true; if (!strcmp(name, "atom_length") && arity == 2) return true; if (!strcmp(name, "number_chars") && arity == 2) return true; if (!strcmp(name, "number_codes") && arity == 2) return true; if (!strcmp(name, "char_code") && arity == 2) return true; if (!strcmp(name, "sub_atom") && arity == 5) return true; if (!strcmp(name, "sub_string") && arity == 5) return true; if (!strcmp(name, "subsumes_term") && arity == 2) return true; if (!strcmp(name, "sort") && arity == 2) return true; if (!strcmp(name, "msort") && arity == 2) return true; if (!strcmp(name, "keysort") && arity == 2) return true; if (!strcmp(name, "call") && (arity >= 1 && arity <= 8)) return true; if (!strcmp(name, ":") && arity == 2) return true; if (!strcmp(name, "catch") && arity == 3) return true; if (!strcmp(name, "throw") && arity == 1) return true; if (!strcmp(name, "once") && arity == 1) return true; if (!strcmp(name, "halt") && arity == 1) return true; if (!strcmp(name, "current_predicate") && arity == 1) return true; if (!strcmp(name, "current_op") && arity == 3) return true; if (!strcmp(name, "op") && arity == 3) return true; if (!strcmp(name, "dynamic") && arity == 1) return true; if (!strcmp(name, "current_prolog_flag") && arity == 2) return true; if (!strcmp(name, "set_prolog_flag") && arity == 2) return true; if (!strcmp(name, "predicate_property") && arity == 2) return true; if (!strcmp(name, "evaluable_property") && arity == 2) return true; if (!strcmp(name, "current_rule") && arity == 1) return true; if (!strcmp(name, "countall") && arity == 2) return true; if (!strcmp(name, "flowlog_cpuproc_id") && arity == 1) return true; if (!strcmp(name, "flowlog_n_cpuproc") && arity == 1) return true; if (!strcmp(name, "flowlog_in_cpuproc") && arity == 1) return true; if (!strcmp(name, "flowlog_taskjob_id") && arity == 1) return true; if (!strcmp(name, "flowlog_n_taskjob") && arity == 1) return true; if (!strcmp(name, "flowlog_last_tc_cp_mask") && arity == 1) return true; if (!strcmp(name, "flowlog_last_tc_cp_count") && arity == 1) return true; if (!strcmp(name, "flowlog_last_tc_worker_count") && arity == 1) return true; if (!strcmp(name, "flowlog_last_tc_start_ok") && arity == 1) return true; if (!strcmp(name, "flowlog_last_tc_start_error_code") && arity == 1) return true; if (!strcmp(name, "flowlog_last_tc_start_error_text") && arity == 1) return true; if (!strcmp(name, "flowlog_db_epochs") && arity == 2) return true; if (!strcmp(name, "flowlog_and_safe") && arity == 2) return true; if (!strcmp(name, "flowlog_and_safe_goal") && arity == 2) return true; if (!strcmp(name, "listing") && arity == 1) return true; if (!strcmp(name, "$flowlog_sleep_ms") && arity == 1) return true; if (!strcmp(name, "$flowlog_inference_limit") && arity == 1) return true; if (!strcmp(name, "$flowlog_inference_limit_shared") && arity == 1) return true; if (!strcmp(name, "call_with_inference_limit") && arity == 3) return true; if (!strcmp(name, "call_with_inference_limit_par") && arity == 3) return true; if (!strcmp(name, "char_conversion") && arity == 2) return true; if (!strcmp(name, "current_char_conversion") && arity == 2) return true; if (!strcmp(name, "length") && arity == 2) return true; if (!strcmp(name, "bounds_possible") && arity == 3) return true; if (!strcmp(name, "findall") && arity == 3) return true; if (!strcmp(name, "bagof") && arity == 3) return true; if (!strcmp(name, "setof") && arity == 3) return true; if (!strcmp(name, "current_input") && arity == 1) return true; if (!strcmp(name, "current_output") && arity == 1) return true; if (!strcmp(name, "current_error") && arity == 1) return true; if (!strcmp(name, "set_input") && arity == 1) return true; if (!strcmp(name, "set_output") && arity == 1) return true; if (!strcmp(name, "set_error") && arity == 1) return true; if (!strcmp(name, "open") && (arity == 3 || arity == 4)) return true; if (!strcmp(name, "close") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "stream_property") && arity == 2) return true; if (!strcmp(name, "set_stream") && arity == 2) return true; if (!strcmp(name, "set_stream_position") && arity == 2) return true; if (!strcmp(name, "get_code") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "get_char") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "get_byte") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "peek_code") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "peek_char") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "peek_byte") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "unget_code") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "unget_char") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "unget_byte") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "put_code") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "put_char") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "put_byte") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "tab") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "nl") && arity == 1) return true; if (!strcmp(name, "flush_output") && arity == 1) return true; if (!strcmp(name, "at_end_of_stream") && arity == 1) return true; if (!strcmp(name, "read") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "read_term") && (arity == 2 || arity == 3)) return true; if (!strcmp(name, "file_to_chars") && arity == 2) return true; if (!strcmp(name, "file_to_bytes") && arity == 2) return true; if (!strcmp(name, "file_to_byte") && arity == 2) return true; if (!strcmp(name, "write") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "writeq") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "write_canonical") && (arity == 1 || arity == 2)) return true; if (!strcmp(name, "write_term") && (arity == 2 || arity == 3)) return true; if (!strcmp(name, "asserta") && arity == 1) return true; if (!strcmp(name, "assertz") && arity == 1) return true; if (!strcmp(name, "assert") && arity == 1) return true; if (!strcmp(name, "retract") && arity == 1) return true; if (!strcmp(name, "retractall") && arity == 1) return true; if (!strcmp(name, "abolish") && arity == 1) return true; if (!strcmp(name, "clause") && arity == 2) return true; if (!strcmp(name, "numbervars") && arity == 3) return true; return false; } static pl_term *deref_term(pl_term *t, const pl_env *env); static bool term_is_nil(const pl_term *t); static bool pstr_uncons_rt(const pl_term *t, pl_term **out_head, pl_term **out_tail, const void *rt_ctrl, const ULO *dbg_dat_ptr); static bool atom_codepoint(const pl_term *t, uint32_t *out_cp); static bool term_identical_pstr_env(const pl_term *a, const pl_term *b, const pl_env *env) { if (!a || !b) { return false; } if (a->tag != PL_TERM_PSTR && b->tag == PL_TERM_PSTR) { const pl_term *tmp = a; a = b; b = tmp; } if (a->tag != PL_TERM_PSTR) { return false; } if (!a->v.pstr.bytes) { return false; } // PSTR vs PSTR: compare runs and then compare tails with environment deref. if (b->tag == PL_TERM_PSTR) { return pstr_terms_equal_with_tail(a, b, pstr_tail_eq_term_identical, env); } // PSTR vs list term: walk `b` as a proper list and compare element-wise. const unsigned char *ap = a->v.pstr.bytes; const pl_term *cur = b; for (ULO guard = 0; guard < 65536; guard++) { if (!ap) { return false; } if (*ap == 0) { pl_term *atail = pstr_tail_term_from_nul(ap); return atail && term_identical_env(atail, (pl_term *)cur, env); } cur = (const pl_term *)deref_term((pl_term *)cur, env); if (!cur) { return false; } if (cur->tag == PL_TERM_PSTR) { pl_term a_rem = {0}; a_rem.tag = PL_TERM_PSTR; a_rem.v.pstr.bytes = ap; return term_identical_pstr_env(&a_rem, cur, env); } if (term_is_nil(cur)) { return false; } if (!term_is_list_pair(cur)) { return false; } const pl_term *h = (const pl_term *)deref_term(cur->v.str.args[0], env); if (!h) { return false; } uint32_t hcp = 0; if (!atom_codepoint(h, &hcp)) { return false; } uint32_t ap_cp = 0; const size_t used = pstr_decode_one(ap, &ap_cp); if (!used || hcp != ap_cp) { return false; } ap += used; cur = cur->v.str.args[1]; } return false; } static bool term_identical_env(const pl_term *a, const pl_term *b, const pl_env *env) { a = (const pl_term *)deref_term((pl_term *)a, env); b = (const pl_term *)deref_term((pl_term *)b, env); if (a == b) { return true; } if (!a || !b) { return false; } if ((a->tag == PL_TERM_PSTR) || (b->tag == PL_TERM_PSTR)) { return term_identical_pstr_env(a, b, env); } if (term_is_integer(a) || term_is_integer(b)) { return term_is_integer(a) && term_is_integer(b) && term_integer_equal(a, b); } if (a->tag != b->tag) { return false; } switch (a->tag) { case PL_TERM_ATOM: return !strcmp(a->v.atom_name, b->v.atom_name); case PL_TERM_INT: return a->v.int_value == b->v.int_value; case PL_TERM_BIGINT: return term_integer_equal(a, b); case PL_TERM_FLOAT: return a->v.float_value == b->v.float_value; case PL_TERM_VAR: return (a->v.var.scope == b->v.var.scope) && (a->v.var.var_id == b->v.var.var_id); case PL_TERM_STRUCT: if (a->v.str.arity != b->v.str.arity) { return false; } if (strcmp(a->v.str.functor, b->v.str.functor)) { return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!term_identical_env(a->v.str.args[i], b->v.str.args[i], env)) { return false; } } return true; case PL_TERM_PSTR: break; } return false; } static pl_term *make_int_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, SLO v) { // Small integer cache: reduces allocation pressure substantially for // arithmetic-heavy search problems (e.g. magic squares). enum { FLOWLOG_SMALL_INT_MIN = -256, FLOWLOG_SMALL_INT_MAX = 4096, FLOWLOG_SMALL_INT_COUNT = (FLOWLOG_SMALL_INT_MAX - FLOWLOG_SMALL_INT_MIN + 1), }; static FLOWLOG_TLS pl_term *cache[FLOWLOG_SMALL_INT_COUNT]; if (v >= FLOWLOG_SMALL_INT_MIN && v <= FLOWLOG_SMALL_INT_MAX) { const size_t idx = (size_t)(v - FLOWLOG_SMALL_INT_MIN); pl_term *t = cache[idx]; if (!t) { // NOTE: Do not allocate cached integers from the shared allocator. // // - Cached ints are read-only and thread-local. // - Allocating via `pool_alloc_persistent()` goes through the shared // allocator, which is slower and can increase contention under OR-par. // // Allocate with libc `malloc()` once per thread and keep for process // lifetime. These are tiny and bounded. t = (pl_term *)malloc(sizeof(*t)); if (!t) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); return NULL; } t->tag = PL_TERM_INT; t->builtin = 0; t->reserved16 = 0; t->v.int_value = v; cache[idx] = t; } return t; } pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_INT; t->builtin = 0; t->reserved16 = 0; t->v.int_value = v; return t; } static pl_term *make_bigint_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_bigint *b) { if (!b) { return make_int_rt(rt_ctrl, dbg_dat_ptr, 0); } SLO v = 0; if (bigint_fits_slo(b, &v)) { return make_int_rt(rt_ctrl, dbg_dat_ptr, v); } pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_BIGINT; t->builtin = 0; t->reserved16 = 0; t->v.bigint = b; return t; } static pl_term *make_float_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, double v) { pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_FLOAT; t->builtin = 0; t->reserved16 = 0; t->v.float_value = v; return t; } static pl_term *make_atom_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *name) { pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_ATOM; t->builtin = builtin_id_from_name_arity(name, 0); t->reserved16 = arith_id_from_name_arity(name, 0); t->v.atom_name = pool_strdup(rt_ctrl, name, dbg_dat_ptr); return t; } static pl_term *make_char_atom_rt(const ULO *dbg_dat_ptr, uint32_t cp) { static FLOWLOG_TLS pl_term *cache[256]; if (cp < 256u) { pl_term *t = cache[cp]; if (t) { return t; } unsigned char tmp[PL_UTF8_MAX_BYTES]; const size_t n = utf8_encode_one(cp, tmp, sizeof(tmp)); t = (pl_term *)malloc(sizeof(*t) + n + 1); if (!t) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); return NULL; } CHR *name = (CHR *)(t + 1); memcpy(name, tmp, n); name[n] = '\0'; t->tag = PL_TERM_ATOM; t->builtin = builtin_id_from_name_arity(name, 0); t->reserved16 = arith_id_from_name_arity(name, 0); t->v.atom_name = name; cache[cp] = t; return t; } unsigned char tmp[PL_UTF8_MAX_BYTES]; const size_t n = utf8_encode_one(cp, tmp, sizeof(tmp)); pl_term *t = (pl_term *)malloc(sizeof(*t) + n + 1); if (!t) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); return NULL; } CHR *name = (CHR *)(t + 1); memcpy(name, tmp, n); name[n] = '\0'; t->tag = PL_TERM_ATOM; t->builtin = builtin_id_from_name_arity(name, 0); t->reserved16 = arith_id_from_name_arity(name, 0); t->v.atom_name = name; return t; } static pl_term *make_nil_rt(const ULO *dbg_dat_ptr) { static FLOWLOG_TLS pl_term *cached = NULL; if (cached) { return cached; } pl_term *t = (pl_term *)malloc(sizeof(*t) + 3); if (!t) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); return NULL; } CHR *name = (CHR *)(t + 1); name[0] = '['; name[1] = ']'; name[2] = '\0'; t->tag = PL_TERM_ATOM; t->builtin = builtin_id_from_name_arity(name, 0); t->reserved16 = arith_id_from_name_arity(name, 0); t->v.atom_name = name; cached = t; return t; } static uint64_t g_var_gen = 0; static pl_term *make_var_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_scope *scope, ULO var_id, const CHR *name) { pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_VAR; t->builtin = 0; t->reserved16 = 0; t->v.var.scope = scope; t->v.var.var_id = var_id; t->v.var.var_name = pool_strdup(rt_ctrl, name, dbg_dat_ptr); return t; } static pl_term *make_fresh_var_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_scope *scope, ULO var_id) { char tmp[64]; const unsigned long long n = (unsigned long long)__sync_fetch_and_add(&g_var_gen, 1); (void)snprintf(tmp, sizeof(tmp), "_G%llu", n); return make_var_rt(rt_ctrl, dbg_dat_ptr, scope, var_id, tmp); } static pl_term *make_struct_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *functor, ULO arity) { pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_STRUCT; t->builtin = builtin_id_from_name_arity(functor, arity); t->reserved16 = arith_id_from_name_arity(functor, arity); t->v.str.arity = arity; t->v.str.functor = pool_strdup(rt_ctrl, functor, dbg_dat_ptr); if (arity) { t->v.str.args = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * arity, dbg_dat_ptr); } else { t->v.str.args = NULL; } return t; } static pl_term *make_struct_shallow_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *functor, ULO arity) { pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_STRUCT; t->builtin = builtin_id_from_name_arity(functor, arity); t->reserved16 = arith_id_from_name_arity(functor, arity); t->v.str.arity = arity; t->v.str.functor = (CHR *)functor; if (arity) { t->v.str.args = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * arity, dbg_dat_ptr); } else { t->v.str.args = NULL; } return t; } static pl_term *make_pstr_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const unsigned char *bytes, ULO len, pl_term *tail) { if (!tail) { tail = make_nil_rt(dbg_dat_ptr); } return make_pstr_utf8_alloc(rt_ctrl, dbg_dat_ptr, bytes, len, tail); } static pl_term *make_pstr_bytes_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const unsigned char *bytes, ULO len, pl_term *tail) { if (!tail) { tail = make_nil_rt(dbg_dat_ptr); } return make_pstr_bytes_alloc(rt_ctrl, dbg_dat_ptr, bytes, len, tail); } static pl_term *make_pstr_slice_bytes_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_term *base, ULO byte_off) { if (!base || base->tag != PL_TERM_PSTR || !base->v.pstr.bytes) { return make_nil_rt(dbg_dat_ptr); } if (!byte_off) { return (pl_term *)base; } const unsigned char *bytes = base->v.pstr.bytes; const unsigned char *p = bytes + byte_off; if (*p == 0) { pl_term *tail = pstr_tail_term_from_nul(p); return tail ? tail : make_nil_rt(dbg_dat_ptr); } pl_term *t = (pl_term *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); t->tag = PL_TERM_PSTR; t->builtin = 0; t->reserved16 = 0; t->v.pstr.bytes = p; return t; } static pl_term *build_list_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term *const *elems, ULO n) { pl_term *tail = make_nil_rt(dbg_dat_ptr); for (ULO i = n; i > 0; i--) { pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = elems[i - 1]; cons->v.str.args[1] = tail; tail = cons; } return tail; } static pl_term *build_repeat_list_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term *elem, ULO n) { pl_term *tail = make_nil_rt(dbg_dat_ptr); if (!n) { return tail; } const size_t align = sizeof(void *); const size_t term_bytes = (size_t)n * sizeof(pl_term); const size_t term_bytes_aligned = (term_bytes + align - 1) & ~(align - 1); const size_t args_bytes = (size_t)n * 2 * sizeof(pl_term *); const size_t total_bytes = term_bytes_aligned + args_bytes; void *mem = pool_alloc(rt_ctrl, (ULO)total_bytes, dbg_dat_ptr); pl_term *terms = (pl_term *)mem; pl_term **args = (pl_term **)((char *)mem + term_bytes_aligned); pl_term *rest = tail; for (ULO i = n; i > 0; i--) { const ULO idx = n - i; pl_term *cons = &terms[idx]; cons->tag = PL_TERM_STRUCT; cons->builtin = 0; cons->reserved16 = 0; cons->v.str.arity = 2; cons->v.str.functor = (CHR *)"."; cons->v.str.args = &args[idx * 2]; cons->v.str.args[0] = elem; cons->v.str.args[1] = rest; rest = cons; } return rest; } static pl_term *build_conjunction_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term *const *goals, ULO n) { if (!n) { return make_atom_rt(rt_ctrl, dbg_dat_ptr, "true"); } pl_term *t = goals[n - 1]; for (ULO i = n; i > 1; i--) { pl_term *conj = make_struct_rt(rt_ctrl, dbg_dat_ptr, ",", 2); conj->v.str.args[0] = goals[i - 2]; conj->v.str.args[1] = t; t = conj; } return t; } typedef struct { pl_term *set_limit; pl_term *catch_goal; pl_term *drop_outer; } pl_call_with_inference_limit_wrap; // Build the (set_limit, catch_goal, drop_outer) goal prefix for call_with_inference_limit/3. // // This is implemented as a rewrite into existing primitives to keep the control-flow // logic shared between the tree and WAM solvers: // - `$flowlog_inference_limit/1` or `$flowlog_inference_limit_shared/1` to set/reset the inference cap // - `catch/3` to convert `inference_limit_exceeded` into `Result = inference_limit_exceeded` // - `call/1` to execute the meta-goal // - a disjunction to reset the limit on redo before requesting the next solution static pl_call_with_inference_limit_wrap build_call_with_inference_limit_wrap_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *limit_pred, pl_term *sub_goal, SLO limit, pl_term *result_term, const void *outer_cut_barrier) { pl_call_with_inference_limit_wrap w = {0}; pl_term *limit_int = make_int_rt(rt_ctrl, dbg_dat_ptr, limit); pl_term *zero_int = make_int_rt(rt_ctrl, dbg_dat_ptr, 0); w.set_limit = make_struct_rt(rt_ctrl, dbg_dat_ptr, limit_pred, 1); w.set_limit->v.str.args[0] = limit_int; pl_term *call_goal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "call", 1); call_goal->v.str.args[0] = sub_goal; pl_term *set_zero1 = make_struct_rt(rt_ctrl, dbg_dat_ptr, limit_pred, 1); set_zero1->v.str.args[0] = zero_int; pl_term *unify_true = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); unify_true->v.str.args[0] = result_term; unify_true->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "true"); // Choicepoint to re-enable the limit on redo before asking Goal for the next solution. pl_term *set_lim2 = make_struct_rt(rt_ctrl, dbg_dat_ptr, limit_pred, 1); set_lim2->v.str.args[0] = limit_int; pl_term *redo = make_struct_rt(rt_ctrl, dbg_dat_ptr, ",", 2); redo->v.str.args[0] = set_lim2; redo->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "fail"); pl_term *choice = make_struct_rt(rt_ctrl, dbg_dat_ptr, ";", 2); choice->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "true"); choice->v.str.args[1] = redo; pl_term *inner_parts[4] = {call_goal, set_zero1, unify_true, choice}; pl_term *inner = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, inner_parts, 4); pl_term *set_zero2 = make_struct_rt(rt_ctrl, dbg_dat_ptr, limit_pred, 1); set_zero2->v.str.args[0] = zero_int; pl_term *unify_il = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); unify_il->v.str.args[0] = result_term; unify_il->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "inference_limit_exceeded"); pl_term *cut_goal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "!"); pl_term *handler_parts[3] = {set_zero2, unify_il, cut_goal}; pl_term *handler = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, handler_parts, 3); w.catch_goal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "catch", 3); w.catch_goal->v.str.args[0] = inner; w.catch_goal->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "inference_limit_exceeded"); w.catch_goal->v.str.args[2] = handler; pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)outer_cut_barrier); w.drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); w.drop_outer->v.str.args[0] = outer_barrier_term; return w; } static pl_term *wrap_var_goals_rt(pl_term *g, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!g || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return g; } if (g->tag == PL_TERM_VAR) { pl_term *call = make_struct_rt(rt_ctrl, dbg_dat_ptr, "call", 1); call->v.str.args[0] = g; return call; } if (g->tag != PL_TERM_STRUCT) { return g; } const CHR *fn = g->v.str.functor; const ULO ar = g->v.str.arity; if (((!strcmp(fn, ",") || !strcmp(fn, ";") || !strcmp(fn, "->")) && (ar == 2))) { g->v.str.args[0] = wrap_var_goals_rt(g->v.str.args[0], rt_ctrl, dbg_dat_ptr, depth + 1); g->v.str.args[1] = wrap_var_goals_rt(g->v.str.args[1], rt_ctrl, dbg_dat_ptr, depth + 1); return g; } if ((!strcmp(fn, "\\+") && (ar == 1)) || (!strcmp(fn, "once") && (ar == 1))) { g->v.str.args[0] = wrap_var_goals_rt(g->v.str.args[0], rt_ctrl, dbg_dat_ptr, depth + 1); return g; } return g; } static pl_term *find_noncallable_goal_env(pl_term *g, const pl_env *env, ULO depth) { if (!g || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return NULL; } pl_term *d = deref_term(g, env); if (!d) { return NULL; } if (d->tag == PL_TERM_VAR) { return NULL; } if (d->tag == PL_TERM_ATOM) { return NULL; } if (d->tag != PL_TERM_STRUCT) { return d; } const CHR *fn = d->v.str.functor; const ULO ar = d->v.str.arity; if (((!strcmp(fn, ",") || !strcmp(fn, ";") || !strcmp(fn, "->")) && (ar == 2))) { pl_term *bad = find_noncallable_goal_env(d->v.str.args[0], env, depth + 1); if (bad) { return bad; } return find_noncallable_goal_env(d->v.str.args[1], env, depth + 1); } if ((!strcmp(fn, "\\+") && (ar == 1)) || (!strcmp(fn, "once") && (ar == 1))) { return find_noncallable_goal_env(d->v.str.args[0], env, depth + 1); } return NULL; } static pl_term *find_noncallable_goal_wam(pl_term *g, ULO depth) { if (!g || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return NULL; } pl_term *d = deref_term_wam(g); if (!d) { return NULL; } if (d->tag == PL_TERM_VAR) { return NULL; } if (d->tag == PL_TERM_ATOM) { return NULL; } if (d->tag != PL_TERM_STRUCT) { return d; } const CHR *fn = d->v.str.functor; const ULO ar = d->v.str.arity; if (((!strcmp(fn, ",") || !strcmp(fn, ";") || !strcmp(fn, "->")) && (ar == 2))) { pl_term *bad = find_noncallable_goal_wam(d->v.str.args[0], depth + 1); if (bad) { return bad; } return find_noncallable_goal_wam(d->v.str.args[1], depth + 1); } if ((!strcmp(fn, "\\+") && (ar == 1)) || (!strcmp(fn, "once") && (ar == 1))) { return find_noncallable_goal_wam(d->v.str.args[0], depth + 1); } return NULL; } static pl_term *freeze_bound_vars_rt(pl_term *t, const pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!t) { return NULL; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return t; } if (t->tag == PL_TERM_VAR) { // Canonicalize variable aliases (X=Y) by returning the dereferenced variable node, // and freeze concrete bindings by returning their bound term. pl_term *d = deref_term(t, env); return d ? d : t; } if (t->tag != PL_TERM_STRUCT) { return t; } pl_term *st = make_struct_shallow_rt(rt_ctrl, dbg_dat_ptr, t->v.str.functor, t->v.str.arity); for (ULO i = 0; i < t->v.str.arity; i++) { st->v.str.args[i] = freeze_bound_vars_rt(t->v.str.args[i], env, rt_ctrl, dbg_dat_ptr, depth + 1); } return st; } static pl_term *freeze_bound_vars_wam_rt(pl_term *t, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!t) { return NULL; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return t; } if (t->tag == PL_TERM_VAR) { // Canonicalize variable aliases (X=Y) by returning the dereferenced variable node, // and freeze concrete bindings by returning their bound term. pl_term *d = deref_term_wam(t); return d ? d : t; } if (t->tag != PL_TERM_STRUCT) { return t; } pl_term *st = make_struct_shallow_rt(rt_ctrl, dbg_dat_ptr, t->v.str.functor, t->v.str.arity); for (ULO i = 0; i < t->v.str.arity; i++) { st->v.str.args[i] = freeze_bound_vars_wam_rt(t->v.str.args[i], rt_ctrl, dbg_dat_ptr, depth + 1); } return st; } static bool term_is_true_atom(pl_term *t, const pl_env *env) { t = deref_term(t, env); return t && (t->tag == PL_TERM_ATOM) && !strcmp(t->v.atom_name, "true"); } /* --- SUBSECTION 13.2: DB Locks & Indexing -------------------------------- */ // Program DB locks and indexing coordination. // prog_db_rlock()/prog_db_wlock() protect predicate tables while indexes update. static inline void prog_db_rlock(pl_program *prog) { if (!prog) { return; } for (;;) { while (atomic_load_explicit(&prog->db_writer, memory_order_acquire)) { // spin } atomic_fetch_add_explicit(&prog->db_readers, 1, memory_order_acquire); if (!atomic_load_explicit(&prog->db_writer, memory_order_acquire)) { return; } atomic_fetch_sub_explicit(&prog->db_readers, 1, memory_order_release); } } static inline void prog_db_runlock(pl_program *prog) { if (!prog) { return; } atomic_fetch_sub_explicit(&prog->db_readers, 1, memory_order_release); } static inline void prog_db_wlock(pl_program *prog) { if (!prog) { return; } int expected = 0; while (!atomic_compare_exchange_weak_explicit(&prog->db_writer, &expected, 1, memory_order_acq_rel, memory_order_acquire)) { expected = 0; } while (atomic_load_explicit(&prog->db_readers, memory_order_acquire)) { // spin } } static inline void prog_db_wunlock(pl_program *prog) { if (!prog) { return; } atomic_store_explicit(&prog->db_writer, 0, memory_order_release); } static inline void prog_index_invalidate(pl_program *prog) { if (!prog) { return; } atomic_fetch_add_explicit(&prog->clause_epoch, 1, memory_order_acq_rel); // Any database change invalidates cached AND-par "safe predicate" analysis. atomic_store_explicit(&prog->and_safe_epoch, 0, memory_order_release); } static inline uint64_t hash_mix64(uint64_t x) { x += 0x9e3779b97f4a7c15ULL; x = (x ^ (x >> 30)) * 0xbf58476d1ce4e5b9ULL; x = (x ^ (x >> 27)) * 0x94d049bb133111ebULL; return x ^ (x >> 31); } static uint64_t hash_cstr(const CHR *s) { uint64_t h = 1469598103934665603ULL; if (!s) { return h; } while (*s) { h ^= (unsigned char)*s++; h *= 1099511628211ULL; } return h; } static uint64_t first_key_hash(const pl_first_key *k) { if (!k) { return 0; } uint64_t h = hash_mix64((uint64_t)k->kind); switch (k->kind) { case PL_FAI_ATOM: h ^= hash_cstr(k->v.atom_name); break; case PL_FAI_INT: h ^= hash_mix64((uint64_t)k->v.int_value); break; case PL_FAI_FLOAT: { uint64_t bits = 0; memcpy(&bits, &k->v.float_value, sizeof(bits)); h ^= hash_mix64(bits); break; } case PL_FAI_FUNCTOR: h ^= hash_cstr(k->v.functor.functor); h ^= hash_mix64((uint64_t)k->v.functor.arity); break; default: break; } return hash_mix64(h); } static bool first_key_equal(const pl_first_key *a, const pl_first_key *b) { if (!a || !b) { return false; } if (a->kind != b->kind) { return false; } switch (a->kind) { case PL_FAI_ATOM: return (a->v.atom_name == b->v.atom_name) || (a->v.atom_name && b->v.atom_name && !strcmp(a->v.atom_name, b->v.atom_name)); case PL_FAI_INT: return a->v.int_value == b->v.int_value; case PL_FAI_FLOAT: { uint64_t ba = 0, bb = 0; memcpy(&ba, &a->v.float_value, sizeof(ba)); memcpy(&bb, &b->v.float_value, sizeof(bb)); return ba == bb; } case PL_FAI_FUNCTOR: if (a->v.functor.arity != b->v.functor.arity) { return false; } return (a->v.functor.functor == b->v.functor.functor) || (a->v.functor.functor && b->v.functor.functor && !strcmp(a->v.functor.functor, b->v.functor.functor)); default: return false; } } static bool first_key_from_term(const pl_term *t, pl_first_key *out_key, uint64_t *out_hash) { if (out_hash) { *out_hash = 0; } if (!t || !out_key) { return false; } if (t->tag == PL_TERM_VAR) { return false; } pl_first_key k = {0}; switch (t->tag) { case PL_TERM_ATOM: k.kind = PL_FAI_ATOM; k.v.atom_name = t->v.atom_name; break; case PL_TERM_INT: k.kind = PL_FAI_INT; k.v.int_value = t->v.int_value; break; case PL_TERM_BIGINT: { SLO v = 0; if (!bigint_fits_slo(t->v.bigint, &v)) { return false; } k.kind = PL_FAI_INT; k.v.int_value = v; break; } case PL_TERM_FLOAT: k.kind = PL_FAI_FLOAT; k.v.float_value = t->v.float_value; break; case PL_TERM_STRUCT: k.kind = PL_FAI_FUNCTOR; k.v.functor.functor = t->v.str.functor; k.v.functor.arity = t->v.str.arity; break; default: return false; } *out_key = k; if (out_hash) { *out_hash = first_key_hash(&k); } return true; } static void pred_index_ensure_capacity(pl_pred_index *idx, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!idx) { return; } if (!want) { want = 1; } if (!idx->preds) { ULO cap = idx->pred_cap ? idx->pred_cap : 16; while (cap < want) { cap *= 2; } idx->preds = (pl_pred_index_entry *)pool_alloc(rt_ctrl, sizeof(pl_pred_index_entry) * cap, dbg_dat_ptr); memset(idx->preds, 0, sizeof(pl_pred_index_entry) * cap); idx->pred_cap = cap; return; } if (idx->pred_cap >= want) { return; } ULO cap = idx->pred_cap ? idx->pred_cap : 16; while (cap < want) { cap *= 2; } pl_pred_index_entry *preds = (pl_pred_index_entry *)pool_alloc(rt_ctrl, sizeof(pl_pred_index_entry) * cap, dbg_dat_ptr); memset(preds, 0, sizeof(pl_pred_index_entry) * cap); for (ULO i = 0; i < idx->pred_count; i++) { preds[i] = idx->preds[i]; } idx->preds = preds; idx->pred_cap = cap; } static uint64_t pred_key_hash(const CHR *name, ULO arity) { uint64_t h = hash_cstr(name); h ^= hash_mix64((uint64_t)arity); return hash_mix64(h); } static void pred_index_ensure_slots(pl_pred_index *idx, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want_slots) { if (!idx) { return; } if (!want_slots) { want_slots = 16; } if (want_slots < 16) { want_slots = 16; } // round up to power-of-two ULO cap = 1; while (cap < want_slots) { cap *= 2; } if (idx->pred_slots && (idx->pred_slot_cap >= cap)) { return; } ULO *slots = (ULO *)pool_alloc(rt_ctrl, sizeof(ULO) * cap, dbg_dat_ptr); memset(slots, 0, sizeof(ULO) * cap); if (idx->preds && idx->pred_count) { for (ULO pi = 0; pi < idx->pred_count; pi++) { const pl_pred_index_entry *e = &idx->preds[pi]; if (!e->name) { continue; } const uint64_t h = pred_key_hash(e->name, e->arity); const ULO mask = cap - 1; ULO pos = (ULO)h & mask; for (;;) { if (!slots[pos]) { slots[pos] = pi + 1; break; } pos = (pos + 1) & mask; } } } idx->pred_slots = slots; idx->pred_slot_cap = cap; } static void pred_index_insert_slot(pl_pred_index *idx, ULO pred_idx, uint64_t hash) { if (!idx) { return; } if (!idx->pred_slots || !idx->pred_slot_cap) { return; } const ULO mask = idx->pred_slot_cap - 1; ULO pos = (ULO)hash & mask; for (;;) { if (!idx->pred_slots[pos]) { idx->pred_slots[pos] = pred_idx + 1; return; } pos = (pos + 1) & mask; } } static void pred_entry_ensure_clause_capacity(pl_pred_index_entry *e, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!e) { return; } if (!want) { want = 1; } if (!e->clauses) { ULO cap = e->clause_cap ? e->clause_cap : 8; while (cap < want) { cap *= 2; } e->clauses = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(const pl_clause *) * cap, dbg_dat_ptr); e->clause_cap = cap; return; } if (e->clause_cap >= want) { return; } ULO cap = e->clause_cap ? e->clause_cap : 8; while (cap < want) { cap *= 2; } const pl_clause **clauses = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(const pl_clause *) * cap, dbg_dat_ptr); for (ULO i = 0; i < e->clause_count; i++) { clauses[i] = e->clauses[i]; } e->clauses = clauses; e->clause_cap = cap; } static void pred_entry_ensure_arg_indexes(pl_pred_index_entry *e, ULO arity, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!e || !arity) { return; } if (e->args && (e->arg_count >= arity)) { return; } pl_arg_index *args = (pl_arg_index *)pool_alloc(rt_ctrl, sizeof(*args) * arity, dbg_dat_ptr); memset(args, 0, sizeof(*args) * arity); if (e->args && e->arg_count) { const ULO copy_n = (e->arg_count < arity) ? e->arg_count : arity; for (ULO i = 0; i < copy_n; i++) { args[i] = e->args[i]; } } e->args = args; e->arg_count = arity; } static void arg_index_ensure_var_capacity(pl_arg_index *ai, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!ai) { return; } if (!want) { want = 1; } if (!ai->var_ords) { ULO cap = ai->var_cap ? ai->var_cap : 8; while (cap < want) { cap *= 2; } ai->var_ords = (ULO *)pool_alloc(rt_ctrl, sizeof(ULO) * cap, dbg_dat_ptr); ai->var_cap = cap; return; } if (ai->var_cap >= want) { return; } ULO cap = ai->var_cap ? ai->var_cap : 8; while (cap < want) { cap *= 2; } ULO *ords = (ULO *)pool_alloc(rt_ctrl, sizeof(ULO) * cap, dbg_dat_ptr); for (ULO i = 0; i < ai->var_count; i++) { ords[i] = ai->var_ords[i]; } ai->var_ords = ords; ai->var_cap = cap; } static void arg_index_ensure_bucket_capacity(pl_arg_index *ai, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!ai) { return; } if (!want) { want = 1; } if (!ai->buckets) { ULO cap = ai->bucket_cap ? ai->bucket_cap : 8; while (cap < want) { cap *= 2; } ai->buckets = (pl_first_bucket *)pool_alloc(rt_ctrl, sizeof(pl_first_bucket) * cap, dbg_dat_ptr); memset(ai->buckets, 0, sizeof(pl_first_bucket) * cap); ai->bucket_cap = cap; return; } if (ai->bucket_cap >= want) { return; } ULO cap = ai->bucket_cap ? ai->bucket_cap : 8; while (cap < want) { cap *= 2; } pl_first_bucket *buckets = (pl_first_bucket *)pool_alloc(rt_ctrl, sizeof(pl_first_bucket) * cap, dbg_dat_ptr); memset(buckets, 0, sizeof(pl_first_bucket) * cap); for (ULO i = 0; i < ai->bucket_count; i++) { buckets[i] = ai->buckets[i]; } ai->buckets = buckets; ai->bucket_cap = cap; } static void bucket_ensure_ord_capacity(pl_first_bucket *b, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!b) { return; } if (!want) { want = 1; } if (!b->ords) { ULO cap = b->ord_cap ? b->ord_cap : 8; while (cap < want) { cap *= 2; } b->ords = (ULO *)pool_alloc(rt_ctrl, sizeof(ULO) * cap, dbg_dat_ptr); b->ord_cap = cap; return; } if (b->ord_cap >= want) { return; } ULO cap = b->ord_cap ? b->ord_cap : 8; while (cap < want) { cap *= 2; } ULO *ords = (ULO *)pool_alloc(rt_ctrl, sizeof(ULO) * cap, dbg_dat_ptr); for (ULO i = 0; i < b->ord_count; i++) { ords[i] = b->ords[i]; } b->ords = ords; b->ord_cap = cap; } static void arg_index_reset(pl_arg_index *ai) { if (!ai) { return; } ai->var_count = 0; ai->bucket_count = 0; if (ai->bucket_slots && ai->bucket_slot_cap) { memset(ai->bucket_slots, 0, sizeof(ULO) * ai->bucket_slot_cap); } } static void arg_index_ensure_bucket_slots(pl_arg_index *ai, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want_slots) { if (!ai) { return; } if (!want_slots) { want_slots = 16; } if (want_slots < 16) { want_slots = 16; } // round up to power-of-two ULO cap = 1; while (cap < want_slots) { cap *= 2; } if (ai->bucket_slots && (ai->bucket_slot_cap >= cap)) { return; } ULO *slots = (ULO *)pool_alloc(rt_ctrl, sizeof(ULO) * cap, dbg_dat_ptr); memset(slots, 0, sizeof(ULO) * cap); if (ai->buckets && ai->bucket_count) { for (ULO bi = 0; bi < ai->bucket_count; bi++) { pl_first_bucket *b = &ai->buckets[bi]; const uint64_t h = b->hash ? b->hash : first_key_hash(&b->key); ULO mask = cap - 1; ULO pos = (ULO)h & mask; for (;;) { if (!slots[pos]) { slots[pos] = bi + 1; break; } pos = (pos + 1) & mask; } } } ai->bucket_slots = slots; ai->bucket_slot_cap = cap; } static pl_first_bucket *arg_index_find_bucket(const pl_arg_index *ai, const pl_first_key *key, uint64_t hash) { if (!ai || !key || !ai->bucket_slots || !ai->bucket_slot_cap) { return NULL; } const ULO mask = ai->bucket_slot_cap - 1; ULO pos = (ULO)hash & mask; for (;;) { const ULO slot = ai->bucket_slots[pos]; if (!slot) { return NULL; } const ULO bi = slot - 1; if (bi < ai->bucket_count) { const pl_first_bucket *b = &ai->buckets[bi]; if (b->hash == hash && first_key_equal(&b->key, key)) { return (pl_first_bucket *)b; } } pos = (pos + 1) & mask; } } static pl_first_bucket *arg_index_find_or_add_bucket(pl_arg_index *ai, const pl_first_key *key, uint64_t hash, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!ai || !key) { return NULL; } // Ensure slot table (keep load factor <= 0.5). ULO want_slots = ai->bucket_slot_cap ? ai->bucket_slot_cap : 0; if (!want_slots) { want_slots = 16; } if (((ai->bucket_count + 1) * 2) >= want_slots) { want_slots = want_slots ? (want_slots * 2) : 16; } arg_index_ensure_bucket_slots(ai, rt_ctrl, dbg_dat_ptr, want_slots); pl_first_bucket *found = arg_index_find_bucket(ai, key, hash); if (found) { return found; } arg_index_ensure_bucket_capacity(ai, rt_ctrl, dbg_dat_ptr, ai->bucket_count + 1); if (!ai->buckets) { return NULL; } // Recompute slots if a growth occurred in ensure_bucket_capacity and we haven't allocated slots yet. if (!ai->bucket_slots || !ai->bucket_slot_cap) { arg_index_ensure_bucket_slots(ai, rt_ctrl, dbg_dat_ptr, 16); } const ULO bi = ai->bucket_count++; pl_first_bucket *b = &ai->buckets[bi]; // Preserve existing ord storage for reused bucket structs. const ULO *old_ords = b->ords; const ULO old_cap = b->ord_cap; pl_arg_index *old_deep0 = b->deep0; memset(b, 0, sizeof(*b)); b->ords = (ULO *)old_ords; b->ord_cap = old_cap; b->deep0 = old_deep0; if (b->deep0) { arg_index_reset(b->deep0); } b->key = *key; b->hash = hash; // Insert into slot table. ULO mask = ai->bucket_slot_cap - 1; ULO pos = (ULO)hash & mask; for (;;) { if (!ai->bucket_slots[pos]) { ai->bucket_slots[pos] = bi + 1; break; } pos = (pos + 1) & mask; } return b; } static pl_pred_index_entry *pred_index_find_pred(pl_pred_index *idx, const CHR *name, ULO arity) { if (!idx || !idx->preds || !idx->pred_count || !name) { return NULL; } if (idx->pred_slots && idx->pred_slot_cap) { const uint64_t h = pred_key_hash(name, arity); const ULO mask = idx->pred_slot_cap - 1; ULO pos = (ULO)h & mask; for (;;) { const ULO slot = idx->pred_slots[pos]; if (!slot) { break; } const ULO pi = slot - 1; if (pi < idx->pred_count) { pl_pred_index_entry *e = &idx->preds[pi]; if (e->name && (e->arity == arity) && ((e->name == name) || !strcmp(e->name, name))) { return e; } } pos = (pos + 1) & mask; } } // Fallback linear scan (robust if slot table is missing/out-of-date). for (ULO i = 0; i < idx->pred_count; i++) { pl_pred_index_entry *e = &idx->preds[i]; if (!e->name) { continue; } if ((e->arity == arity) && ((e->name == name) || !strcmp(e->name, name))) { return e; } } return NULL; } static void pred_entry_reset(pl_pred_index_entry *e) { if (!e) { return; } e->clause_count = 0; e->and_safe = 0; if (e->args && e->arg_count) { for (ULO ai = 0; ai < e->arg_count; ai++) { arg_index_reset(&e->args[ai]); } } } typedef struct { const ULO *ords; ULO count; ULO i; } pl_ords_iter; static ULO ords_merge_sorted_k(ULO *dst, pl_ords_iter *iters, ULO k) { if (!dst || !iters || !k) { return 0; } ULO out = 0; for (;;) { bool have = false; ULO ord = 0; for (ULO li = 0; li < k; li++) { pl_ords_iter *it = &iters[li]; if (!it->ords || it->i >= it->count) { continue; } const ULO v = it->ords[it->i]; if (!have || (v < ord)) { ord = v; have = true; } } if (!have) { break; } for (ULO li = 0; li < k; li++) { pl_ords_iter *it = &iters[li]; if (!it->ords || it->i >= it->count) { continue; } if (it->ords[it->i] == ord) { it->i++; } } dst[out++] = ord; } return out; } enum { FLOWLOG_DEEP_INDEX_MAX = 3, // max nested arg0 levels within a compound/list argument (e.g. f(g(h(X))) => depth 3) }; static void bucket_index_deep0(pl_first_bucket *b, const pl_term *t, ULO ord, ULO depth, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!b || !t) { return; } if (depth >= FLOWLOG_DEEP_INDEX_MAX) { return; } if (t->tag != PL_TERM_STRUCT || !t->v.str.arity || !t->v.str.args || !t->v.str.args[0]) { return; } if (!b->deep0) { b->deep0 = (pl_arg_index *)pool_alloc(rt_ctrl, sizeof(*b->deep0), dbg_dat_ptr); memset(b->deep0, 0, sizeof(*b->deep0)); } pl_arg_index *d = b->deep0; if (!d) { return; } const pl_term *sub0 = t->v.str.args[0]; if (!sub0) { return; } if (sub0->tag == PL_TERM_VAR) { arg_index_ensure_var_capacity(d, rt_ctrl, dbg_dat_ptr, d->var_count + 1); if (!d->var_ords) { return; } d->var_ords[d->var_count++] = ord; return; } pl_first_key sk = {0}; uint64_t sh = 0; if (!first_key_from_term(sub0, &sk, &sh)) { return; } pl_first_bucket *db = arg_index_find_or_add_bucket(d, &sk, sh, rt_ctrl, dbg_dat_ptr); if (!db) { return; } bucket_ensure_ord_capacity(db, rt_ctrl, dbg_dat_ptr, db->ord_count + 1); if (!db->ords) { return; } db->ords[db->ord_count++] = ord; if ((sk.kind == PL_FAI_FUNCTOR) && (sub0->tag == PL_TERM_STRUCT) && sub0->v.str.arity && sub0->v.str.args && sub0->v.str.args[0]) { bucket_index_deep0(db, sub0, ord, depth + 1, rt_ctrl, dbg_dat_ptr); } } static ULO ords_intersect_sorted(ULO *dst, const ULO *a, ULO ac, const ULO *b, ULO bc) { if (!dst) { return 0; } ULO i = 0; ULO j = 0; ULO k = 0; while (i < ac && j < bc) { if (a[i] == b[j]) { dst[k++] = a[i]; i++; j++; } else if (a[i] < b[j]) { i++; } else { j++; } } return k; } static void prog_index_build_locked(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog) { return; } if (!prog->pred_index) { prog->pred_index = (pl_pred_index *)pool_alloc(rt_ctrl, sizeof(*prog->pred_index), dbg_dat_ptr); memset(prog->pred_index, 0, sizeof(*prog->pred_index)); } pl_pred_index *idx = prog->pred_index; // Reset existing predicate entries so we can rebuild in-place without losing allocated buffers. for (ULO i = 0; i < idx->pred_count; i++) { pred_entry_reset(&idx->preds[i]); } // Ensure predicate slot table exists so predicate lookups are O(1) average during (re)builds. if (!idx->pred_slots || !idx->pred_slot_cap) { pred_index_ensure_slots(idx, rt_ctrl, dbg_dat_ptr, idx->pred_count ? (idx->pred_count * 2) : 16); } if (!prog->clauses || !prog->clause_count) { return; } for (ULO i = 1; i <= prog->clause_count; i++) { pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { continue; } if (!pred_name) { continue; } pl_pred_index_entry *e = pred_index_find_pred(idx, pred_name, pred_arity); if (!e) { // Ensure slot table (keep load factor <= 0.5). ULO want_slots = idx->pred_slot_cap ? idx->pred_slot_cap : 0; if (!want_slots) { want_slots = 16; } if (((idx->pred_count + 1) * 2) >= want_slots) { want_slots = want_slots ? (want_slots * 2) : 16; } pred_index_ensure_slots(idx, rt_ctrl, dbg_dat_ptr, want_slots); pred_index_ensure_capacity(idx, rt_ctrl, dbg_dat_ptr, idx->pred_count + 1); if (!idx->preds || (idx->pred_count >= idx->pred_cap)) { return; } const ULO pi = idx->pred_count++; e = &idx->preds[pi]; if (!e->name) { // brand-new slot: leave buffers NULL and caps 0. } e->name = pred_name; e->arity = pred_arity; e->clause_count = 0; e->arg_count = 0; e->args = NULL; e->and_safe = 0; pred_index_insert_slot(idx, pi, pred_key_hash(pred_name, pred_arity)); } pred_entry_ensure_clause_capacity(e, rt_ctrl, dbg_dat_ptr, e->clause_count + 1); if (!e->clauses) { return; } const ULO ord = e->clause_count; e->clauses[e->clause_count++] = cl; if (pred_arity == 0) { continue; } if (h->tag != PL_TERM_STRUCT || !h->v.str.args || !h->v.str.arity) { continue; } pred_entry_ensure_arg_indexes(e, pred_arity, rt_ctrl, dbg_dat_ptr); if (!e->args || (e->arg_count < pred_arity)) { return; } for (ULO ai = 0; ai < pred_arity; ai++) { pl_arg_index *aidx = &e->args[ai]; const pl_term *arg = h->v.str.args[ai]; if (!arg) { continue; } if (arg->tag == PL_TERM_VAR) { arg_index_ensure_var_capacity(aidx, rt_ctrl, dbg_dat_ptr, aidx->var_count + 1); if (!aidx->var_ords) { return; } aidx->var_ords[aidx->var_count++] = ord; continue; } pl_first_key key = {0}; uint64_t hsh = 0; if (!first_key_from_term(arg, &key, &hsh)) { continue; } pl_first_bucket *b = arg_index_find_or_add_bucket(aidx, &key, hsh, rt_ctrl, dbg_dat_ptr); if (!b) { continue; } bucket_ensure_ord_capacity(b, rt_ctrl, dbg_dat_ptr, b->ord_count + 1); if (!b->ords) { return; } b->ords[b->ord_count++] = ord; // Deeper indexing: for compound/list arguments, also index arg0 chains inside this functor bucket. if ((key.kind == PL_FAI_FUNCTOR) && (arg->tag == PL_TERM_STRUCT)) { bucket_index_deep0(b, arg, ord, 0, rt_ctrl, dbg_dat_ptr); } } } } // Incremental index maintenance for append-only database updates (assertz/1). // Requires: prog_db_wlock(prog) is held, and prog->index_epoch == prog->clause_epoch before the update. static void prog_index_append_clause_locked(pl_program *prog, pl_clause *cl, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !prog->pred_index || !cl || !cl->head) { return; } const pl_term *h = cl->head; const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { return; } if (!pred_name) { return; } pl_pred_index *idx = prog->pred_index; if (!idx->pred_slots || !idx->pred_slot_cap) { pred_index_ensure_slots(idx, rt_ctrl, dbg_dat_ptr, idx->pred_count ? (idx->pred_count * 2) : 16); } pl_pred_index_entry *e = pred_index_find_pred(idx, pred_name, pred_arity); if (!e) { // Ensure slot table (keep load factor <= 0.5). ULO want_slots = idx->pred_slot_cap ? idx->pred_slot_cap : 0; if (!want_slots) { want_slots = 16; } if (((idx->pred_count + 1) * 2) >= want_slots) { want_slots = want_slots ? (want_slots * 2) : 16; } pred_index_ensure_slots(idx, rt_ctrl, dbg_dat_ptr, want_slots); pred_index_ensure_capacity(idx, rt_ctrl, dbg_dat_ptr, idx->pred_count + 1); if (!idx->preds || (idx->pred_count >= idx->pred_cap)) { return; } const ULO pi = idx->pred_count++; e = &idx->preds[pi]; e->name = pred_name; e->arity = pred_arity; e->clauses = NULL; e->clause_count = 0; e->clause_cap = 0; e->args = NULL; e->arg_count = 0; e->and_safe = 0; pred_index_insert_slot(idx, pi, pred_key_hash(pred_name, pred_arity)); } pred_entry_ensure_clause_capacity(e, rt_ctrl, dbg_dat_ptr, e->clause_count + 1); if (!e->clauses) { return; } const ULO ord = e->clause_count; e->clauses[e->clause_count++] = cl; if (!pred_arity) { return; } if (h->tag != PL_TERM_STRUCT || !h->v.str.args || !h->v.str.arity) { return; } pred_entry_ensure_arg_indexes(e, pred_arity, rt_ctrl, dbg_dat_ptr); if (!e->args || (e->arg_count < pred_arity)) { return; } for (ULO ai = 0; ai < pred_arity; ai++) { pl_arg_index *aidx = &e->args[ai]; const pl_term *arg = h->v.str.args[ai]; if (!arg) { continue; } if (arg->tag == PL_TERM_VAR) { arg_index_ensure_var_capacity(aidx, rt_ctrl, dbg_dat_ptr, aidx->var_count + 1); if (!aidx->var_ords) { return; } aidx->var_ords[aidx->var_count++] = ord; continue; } pl_first_key key = {0}; uint64_t hsh = 0; if (!first_key_from_term(arg, &key, &hsh)) { continue; } pl_first_bucket *b = arg_index_find_or_add_bucket(aidx, &key, hsh, rt_ctrl, dbg_dat_ptr); if (!b) { continue; } bucket_ensure_ord_capacity(b, rt_ctrl, dbg_dat_ptr, b->ord_count + 1); if (!b->ords) { return; } b->ords[b->ord_count++] = ord; if ((key.kind == PL_FAI_FUNCTOR) && (arg->tag == PL_TERM_STRUCT)) { bucket_index_deep0(b, arg, ord, 0, rt_ctrl, dbg_dat_ptr); } } } static void prog_index_ensure(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog) { return; } const unsigned long cur = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long built = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); if (built == cur) { return; } prog_db_wlock(prog); const unsigned long cur2 = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long built2 = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); if (built2 != cur2) { pl_temp_alloc *saved_tmp = NULL; if (g_temp_alloc) { saved_tmp = temp_alloc_suspend(); } prog_index_build_locked(prog, rt_ctrl, dbg_dat_ptr); if (saved_tmp) { temp_alloc_resume(saved_tmp); } atomic_store_explicit(&prog->index_epoch, cur2, memory_order_release); } prog_db_wunlock(prog); } /* --- SUBSECTION 13.3: Clause Snapshots ----------------------------------- */ // Clause storage and dynamic predicate maintenance. // prog_ensure_clause_capacity()/prog_ensure_dyn_pred_capacity() grow tables; prog_dyn_pred_contains()/prog_dyn_pred_add() update sets. static const pl_clause **prog_snapshot_pred_cands(pl_program *prog, const CHR *name, ULO arity, const pl_term *goal, const pl_env *env, ULO *out_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (out_count) { *out_count = 0; } if (!prog || !name || !out_count) { return NULL; } // Shared, immutable empty list used when indexing proves there are no // candidates. Returning a non-NULL pointer avoids triggering slow fallbacks // in callers that treat NULL as "predicate not found / unknown". static const pl_clause *const empty_list[1] = {NULL}; typedef struct { const ULO *lists[8]; ULO counts[8]; ULO list_count; ULO union_count; } pl_idx_constraint; for (;;) { prog_db_rlock(prog); const unsigned long cur = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long built = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); if (built != cur) { prog_db_runlock(prog); prog_index_ensure(prog, rt_ctrl, dbg_dat_ptr); continue; } pl_pred_index *idx = prog->pred_index; pl_pred_index_entry *e = pred_index_find_pred(idx, name, arity); if (!e || !e->clauses || !e->clause_count) { prog_db_runlock(prog); return NULL; } // Fast path for small predicates: return the full clause list in order. // This avoids per-call allocations and indexing overhead for common small // helpers (e.g., 2-clause recursive predicates) that appear frequently in // search workloads. if (e->clause_count <= (ULO)FLOWLOG_PRED_CANDS_DIRECT_MAX) { *out_count = e->clause_count; const pl_clause **cands = e->clauses; prog_db_runlock(prog); return cands; } // No args: use the full predicate list. if (!arity) { *out_count = e->clause_count; const pl_clause **cands = e->clauses; prog_db_runlock(prog); return cands; } // Multi-arg indexing: build constraints for bound, indexable arguments and intersect them, preserving clause order. if (!e->args || (e->arg_count < arity) || !goal || (goal->tag != PL_TERM_STRUCT) || !goal->v.str.args || (goal->v.str.arity < arity)) { *out_count = e->clause_count; const pl_clause **cands = e->clauses; prog_db_runlock(prog); return cands; } enum { MAX_CONSTRAINTS = 16 }; pl_idx_constraint cs[MAX_CONSTRAINTS]; ULO ccount = 0; const ULO full_n = e->clause_count; bool any_filter = false; for (ULO ai = 0; ai < arity; ai++) { pl_term *arg = deref_term(goal->v.str.args[ai], env); if (!arg || (arg->tag == PL_TERM_VAR)) { continue; } pl_first_key key = {0}; uint64_t hsh = 0; if (!first_key_from_term(arg, &key, &hsh)) { continue; } const pl_arg_index *aidx = &e->args[ai]; const pl_first_bucket *b0 = arg_index_find_bucket(aidx, &key, hsh); const pl_arg_index *idxs[FLOWLOG_DEEP_INDEX_MAX + 1]; const pl_first_bucket *bs[FLOWLOG_DEEP_INDEX_MAX + 1]; pl_term *ts[FLOWLOG_DEEP_INDEX_MAX + 1]; idxs[0] = aidx; bs[0] = b0; ts[0] = arg; ULO best_depth = 0; ULO sum_vars = aidx->var_count; ULO best_count = (b0 ? b0->ord_count : 0) + sum_vars; // Follow arg0 chains (bounded) and choose the tightest candidate set, while preserving classic clause order. for (ULO depth = 1; depth <= FLOWLOG_DEEP_INDEX_MAX; depth++) { const pl_first_bucket *prev_b = bs[depth - 1]; pl_term *prev_t = ts[depth - 1]; if (!prev_b || !prev_b->deep0) { break; } if (!prev_t || (prev_t->tag != PL_TERM_STRUCT) || !prev_t->v.str.arity || !prev_t->v.str.args || !prev_t->v.str.args[0]) { break; } pl_term *sub0 = deref_term(prev_t->v.str.args[0], env); if (!sub0 || (sub0->tag == PL_TERM_VAR)) { break; } pl_first_key sk = {0}; uint64_t sh = 0; if (!first_key_from_term(sub0, &sk, &sh)) { break; } const pl_arg_index *next_idx = prev_b->deep0; const pl_first_bucket *next_b = arg_index_find_bucket(next_idx, &sk, sh); idxs[depth] = next_idx; bs[depth] = next_b; ts[depth] = sub0; sum_vars += next_idx->var_count; const ULO bc = next_b ? next_b->ord_count : 0; const ULO cand = bc + sum_vars; if (cand < best_count) { best_count = cand; best_depth = depth; } if (!next_b) { break; } } pl_idx_constraint c = {0}; const pl_first_bucket *best_b = bs[best_depth]; if (best_b && best_b->ord_count && c.list_count < 8) { c.lists[c.list_count] = best_b->ords; c.counts[c.list_count] = best_b->ord_count; c.union_count += best_b->ord_count; c.list_count++; } for (ULO d = 0; d <= best_depth; d++) { const pl_arg_index *idxd = idxs[d]; if (idxd && idxd->var_count && idxd->var_ords && c.list_count < 8) { c.lists[c.list_count] = idxd->var_ords; c.counts[c.list_count] = idxd->var_count; c.union_count += idxd->var_count; c.list_count++; } } const ULO union_count = c.union_count; if (!union_count) { // Indexed but no candidates: fail early without triggering fallback scans. *out_count = 0; prog_db_runlock(prog); return (const pl_clause **)&empty_list[0]; } if (union_count < full_n) { any_filter = true; } if (ccount < MAX_CONSTRAINTS) { cs[ccount++] = c; } } // No usable constraints: return full clause list. if (!ccount || !any_filter) { *out_count = e->clause_count; const pl_clause **cands = e->clauses; prog_db_runlock(prog); return cands; } // Pick the tightest constraint as the starting candidate set. ULO best_i = 0; for (ULO i = 1; i < ccount; i++) { if (cs[i].union_count < cs[best_i].union_count) { best_i = i; } } const pl_idx_constraint best = cs[best_i]; ULO cur_count = best.union_count; ULO *cur_ords = (ULO *)pool_alloc(rt_ctrl, sizeof(*cur_ords) * (cur_count ? cur_count : 1), dbg_dat_ptr); pl_ords_iter best_iters[8]; for (ULO i = 0; i < best.list_count && i < 8; i++) { best_iters[i] = (pl_ords_iter){.ords = best.lists[i], .count = best.counts[i], .i = 0}; } cur_count = ords_merge_sorted_k(cur_ords, best_iters, best.list_count); for (ULO ci = 0; ci < ccount && cur_count; ci++) { if (ci == best_i) { continue; } const pl_idx_constraint c = cs[ci]; if (c.union_count >= full_n) { continue; // no filtering power } const ULO union_n = c.union_count; if (!union_n) { cur_count = 0; break; } ULO *allow = (ULO *)pool_alloc(rt_ctrl, sizeof(*allow) * union_n, dbg_dat_ptr); pl_ords_iter allow_iters[8]; for (ULO i = 0; i < c.list_count && i < 8; i++) { allow_iters[i] = (pl_ords_iter){.ords = c.lists[i], .count = c.counts[i], .i = 0}; } const ULO allow_n = ords_merge_sorted_k(allow, allow_iters, c.list_count); ULO *next = (ULO *)pool_alloc(rt_ctrl, sizeof(*next) * (cur_count < allow_n ? cur_count : allow_n), dbg_dat_ptr); cur_count = ords_intersect_sorted(next, cur_ords, cur_count, allow, allow_n); cur_ords = next; } const pl_clause **cands = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(*cands) * (cur_count ? cur_count : 1), dbg_dat_ptr); for (ULO i = 0; i < cur_count; i++) { const ULO ord = cur_ords[i]; if (ord < e->clause_count) { cands[i] = e->clauses[ord]; } else { cands[i] = NULL; } } *out_count = cur_count; prog_db_runlock(prog); return cands; } } static void prog_ensure_clause_capacity(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!prog) { return; } if (!want) { want = 1; } if (!prog->clauses) { ULO cap = prog->clause_cap ? prog->clause_cap : 8; while (cap < want) { cap *= 2; } prog->clauses = (pl_clause **)pool_alloc(rt_ctrl, sizeof(pl_clause *) * (cap + 1), dbg_dat_ptr); memset(prog->clauses, 0, sizeof(pl_clause *) * (cap + 1)); prog->clauses[0] = NULL; prog->clause_cap = cap; return; } if (prog->clause_cap >= want) { return; } ULO new_cap = prog->clause_cap ? prog->clause_cap : 8; while (new_cap < want) { new_cap *= 2; } pl_clause **new_clauses = (pl_clause **)pool_alloc(rt_ctrl, sizeof(pl_clause *) * (new_cap + 1), dbg_dat_ptr); memset(new_clauses, 0, sizeof(pl_clause *) * (new_cap + 1)); new_clauses[0] = NULL; for (ULO i = 1; i <= prog->clause_count; i++) { new_clauses[i] = prog->clauses[i]; } prog->clauses = new_clauses; prog->clause_cap = new_cap; } static void prog_insert_clause(pl_program *prog, pl_clause *cl, bool at_front, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !cl) { return; } prog_db_wlock(prog); prog_ensure_clause_capacity(prog, rt_ctrl, dbg_dat_ptr, prog->clause_count + 1); if (!prog->clauses) { prog_db_wunlock(prog); return; } if (at_front) { for (ULO i = prog->clause_count + 1; i > 1; i--) { prog->clauses[i] = prog->clauses[i - 1]; } prog->clauses[1] = cl; prog->clause_count++; prog_index_invalidate(prog); prog_db_wunlock(prog); return; } prog->clauses[++prog->clause_count] = cl; // Dynamic reindex heuristic: avoid full index rebuilds for append-only updates (assertz/1). const unsigned long cur = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long built = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); const bool can_incremental = (prog->pred_index != NULL) && (built == cur); if (can_incremental) { const unsigned long new_epoch = atomic_fetch_add_explicit(&prog->clause_epoch, 1, memory_order_acq_rel) + 1; atomic_store_explicit(&prog->and_safe_epoch, 0, memory_order_release); prog_index_append_clause_locked(prog, cl, rt_ctrl, dbg_dat_ptr); atomic_store_explicit(&prog->index_epoch, new_epoch, memory_order_release); } else { prog_index_invalidate(prog); } prog_db_wunlock(prog); } static void prog_ensure_dyn_pred_capacity(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!prog) { return; } if (!want) { want = 1; } if (!prog->dyn_preds) { ULO cap = prog->dyn_pred_cap ? prog->dyn_pred_cap : 8; while (cap < want) { cap *= 2; } prog->dyn_preds = (pl_dyn_pred *)pool_alloc(rt_ctrl, sizeof(pl_dyn_pred) * (cap + 1), dbg_dat_ptr); memset(prog->dyn_preds, 0, sizeof(pl_dyn_pred) * (cap + 1)); prog->dyn_preds[0] = (pl_dyn_pred){0}; prog->dyn_pred_cap = cap; return; } if (prog->dyn_pred_cap >= want) { return; } ULO new_cap = prog->dyn_pred_cap ? prog->dyn_pred_cap : 8; while (new_cap < want) { new_cap *= 2; } pl_dyn_pred *new_preds = (pl_dyn_pred *)pool_alloc(rt_ctrl, sizeof(pl_dyn_pred) * (new_cap + 1), dbg_dat_ptr); memset(new_preds, 0, sizeof(pl_dyn_pred) * (new_cap + 1)); new_preds[0] = (pl_dyn_pred){0}; for (ULO i = 1; i <= prog->dyn_pred_count; i++) { new_preds[i] = prog->dyn_preds[i]; } prog->dyn_preds = new_preds; prog->dyn_pred_cap = new_cap; } static bool prog_dyn_pred_contains(const pl_program *prog, const CHR *name, ULO arity) { if (!prog || !prog->dyn_preds || !prog->dyn_pred_count || !name) { return false; } for (ULO i = 1; i <= prog->dyn_pred_count; i++) { const pl_dyn_pred *dp = &prog->dyn_preds[i]; if (!dp || !dp->name) { continue; } if (!strcmp(dp->name, name) && (dp->arity == arity)) { return true; } } return false; } static void prog_dyn_pred_add(pl_program *prog, const CHR *name, ULO arity, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !name) { return; } if (prog_dyn_pred_contains(prog, name, arity)) { return; } // Dynamic predicate declarations are permanent program mutations; ensure both // the dyn_pred table and stored name survive query backtracking. pl_temp_alloc *saved_tmp = temp_alloc_suspend(); const CHR *name_copy = pool_strdup(rt_ctrl, name, dbg_dat_ptr); prog_ensure_dyn_pred_capacity(prog, rt_ctrl, dbg_dat_ptr, prog->dyn_pred_count + 1); if (!prog->dyn_preds) { temp_alloc_resume(saved_tmp); return; } prog->dyn_pred_count++; prog->dyn_preds[prog->dyn_pred_count] = (pl_dyn_pred){.name = (CHR *)name_copy, .arity = arity}; temp_alloc_resume(saved_tmp); } static void prog_dyn_pred_remove(pl_program *prog, const CHR *name, ULO arity) { if (!prog || !prog->dyn_preds || !prog->dyn_pred_count || !name) { return; } ULO out = 0; for (ULO i = 1; i <= prog->dyn_pred_count; i++) { pl_dyn_pred dp = prog->dyn_preds[i]; if (!dp.name) { continue; } if (!strcmp(dp.name, name) && (dp.arity == arity)) { continue; } prog->dyn_preds[++out] = dp; } for (ULO i = out + 1; i <= prog->dyn_pred_count; i++) { prog->dyn_preds[i] = (pl_dyn_pred){0}; } prog->dyn_pred_count = out; } static void prog_ensure_tabled_pred_capacity(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO want) { if (!prog) { return; } if (!want) { want = 1; } if (!prog->tabled_preds) { ULO cap = prog->tabled_pred_cap ? prog->tabled_pred_cap : 8; while (cap < want) { cap *= 2; } prog->tabled_preds = (pl_dyn_pred *)pool_alloc(rt_ctrl, sizeof(pl_dyn_pred) * (cap + 1), dbg_dat_ptr); memset(prog->tabled_preds, 0, sizeof(pl_dyn_pred) * (cap + 1)); prog->tabled_preds[0] = (pl_dyn_pred){0}; prog->tabled_pred_cap = cap; return; } if (prog->tabled_pred_cap >= want) { return; } ULO new_cap = prog->tabled_pred_cap ? prog->tabled_pred_cap : 8; while (new_cap < want) { new_cap *= 2; } pl_dyn_pred *new_preds = (pl_dyn_pred *)pool_alloc(rt_ctrl, sizeof(pl_dyn_pred) * (new_cap + 1), dbg_dat_ptr); memset(new_preds, 0, sizeof(pl_dyn_pred) * (new_cap + 1)); new_preds[0] = (pl_dyn_pred){0}; for (ULO i = 1; i <= prog->tabled_pred_count; i++) { new_preds[i] = prog->tabled_preds[i]; } prog->tabled_preds = new_preds; prog->tabled_pred_cap = new_cap; } static bool prog_tabled_pred_contains(const pl_program *prog, const CHR *name, ULO arity) { if (!prog || !prog->tabled_preds || !prog->tabled_pred_count || !name) { return false; } for (ULO i = 1; i <= prog->tabled_pred_count; i++) { const pl_dyn_pred *tp = &prog->tabled_preds[i]; if (!tp || !tp->name) { continue; } if (!strcmp(tp->name, name) && (tp->arity == arity)) { return true; } } return false; } static void prog_tabled_pred_add(pl_program *prog, const CHR *name, ULO arity, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !name) { return; } if (prog_tabled_pred_contains(prog, name, arity)) { return; } prog_ensure_tabled_pred_capacity(prog, rt_ctrl, dbg_dat_ptr, prog->tabled_pred_count + 1); if (!prog->tabled_preds) { return; } prog->tabled_pred_count++; prog->tabled_preds[prog->tabled_pred_count] = (pl_dyn_pred){.name = (CHR *)name, .arity = arity}; } static inline ULO env_next_pow2_ulo(ULO v) { if (v <= 1) { return 1; } v--; v |= v >> 1; v |= v >> 2; v |= v >> 4; v |= v >> 8; v |= v >> 16; if (sizeof(ULO) >= 8) { v |= v >> 32; } return v + 1; } static inline uint64_t env_hash_key(const pl_scope *scope, ULO var_id) { // Mix pointer + var_id; good enough for open-addressing env lookup. uint64_t x = (uint64_t)(uintptr_t)scope; x ^= x >> 33; x *= 0xff51afd7ed558ccdULL; x ^= x >> 33; x *= 0xc4ceb9fe1a85ec53ULL; x ^= x >> 33; x ^= (uint64_t)var_id + 0x9e3779b97f4a7c15ULL + (x << 6) + (x >> 2); return x; } static void env_map_insert_raw(pl_env_map_entry *map, ULO cap, const pl_scope *scope, ULO var_id, pl_term *value) { if (!map || !cap) { return; } const ULO mask = cap - 1; ULO idx = (ULO)env_hash_key(scope, var_id) & mask; for (;;) { pl_env_map_entry *e = &map[idx]; if (!e->scope) { e->scope = scope; e->var_id = var_id; e->value = value; return; } if ((e->scope == scope) && (e->var_id == var_id)) { e->value = value; return; } idx = (idx + 1) & mask; } } static void env_map_rebuild(pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO new_cap) { if (!env) { return; } if (new_cap < 16) { new_cap = 16; } // Keep cap a power of two for fast masking. new_cap = env_next_pow2_ulo(new_cap); pl_env_map_entry *map = (pl_env_map_entry *)pool_alloc(rt_ctrl, sizeof(*map) * new_cap, dbg_dat_ptr); memset(map, 0, sizeof(*map) * new_cap); // Rehash all bindings; later bindings override earlier ones. for (ULO i = 0; i < env->count; i++) { const pl_binding *b = &env->items[i]; if (b->scope) { env_map_insert_raw(map, new_cap, b->scope, b->var_id, b->value); } } env->map = map; env->map_cap = new_cap; } static bool env_map_maybe_rebuild(pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO extra_bindings) { if (!env) { return false; } const ULO need = env->count + extra_bindings; if (!need) { return false; } if (!env->map || !env->map_cap) { if (need < (ULO)FLOWLOG_ENV_MAP_MIN_BINDINGS) { return false; } // Start with ~2x capacity to keep load factor low. env_map_rebuild(env, rt_ctrl, dbg_dat_ptr, need * 2); return true; } // Grow when load factor would exceed ~0.75 (count includes duplicates; still safe). if ((need * 4) >= (env->map_cap * 3)) { ULO new_cap = env->map_cap * 2; if (new_cap < (need * 2)) { new_cap = need * 2; } env_map_rebuild(env, rt_ctrl, dbg_dat_ptr, new_cap); return true; } return false; } static inline pl_term *env_map_lookup(const pl_env *env, const pl_scope *scope, ULO var_id) { if (!env || !env->map || !env->map_cap) { return NULL; } const ULO mask = env->map_cap - 1; ULO idx = (ULO)env_hash_key(scope, var_id) & mask; for (;;) { const pl_env_map_entry *e = &env->map[idx]; if (!e->scope) { return NULL; } if ((e->scope == scope) && (e->var_id == var_id)) { return e->value; } idx = (idx + 1) & mask; } } static pl_term *env_lookup(const pl_env *env, const pl_scope *scope, ULO var_id) { for (const pl_env *cur = env; cur; cur = cur->parent) { if (cur->map && cur->map_cap) { pl_term *v = env_map_lookup(cur, scope, var_id); if (v) { return v; } if (cur->intro_scope == scope) { break; } continue; } // Slow path (should be rare): linear scan over bindings. if (cur->items) { for (ULO i = cur->count; i > 0; i--) { const pl_binding *b = &cur->items[i - 1]; if ((b->scope == scope) && (b->var_id == var_id)) { return b->value; } } } if (cur->intro_scope == scope) { break; } } return NULL; } static void env_bind(pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_scope *scope, ULO var_id, pl_term *value); // Unifier-only optimization: when a variable lookup succeeds in an ancestor // environment, cache that binding in the current environment frame. This // reduces repeated parent-chain scans during heavy unification workloads (e.g. // pure recursive search) while preserving ISO-visible semantics. // // IMPORTANT: `env` must be a mutable, thread-local environment frame (the // current leaf). We intentionally do not mutate ancestor frames because they // may be shared across alternatives (especially under OR-par). static pl_term *env_lookup_cache_bind(pl_env *env, const pl_scope *scope, ULO var_id, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!env) { return NULL; } // First, try the current frame only (no ancestor scan). if (env->map && env->map_cap) { pl_term *v = env_map_lookup(env, scope, var_id); if (v) { return v; } } else if (env->items) { for (ULO i = env->count; i > 0; i--) { const pl_binding *b = &env->items[i - 1]; if ((b->scope == scope) && (b->var_id == var_id)) { return b->value; } } } if (env->intro_scope == scope) { return NULL; } // Scan ancestors to find the binding. Cache only when the match is deeper // than the immediate parent: avoiding `env_bind` for the common case keeps // the win focused on truly deep env chains. pl_term *found = NULL; ULO steps = 0; for (const pl_env *cur = env->parent; cur; cur = cur->parent) { steps++; if (cur->map && cur->map_cap) { found = env_map_lookup(cur, scope, var_id); if (found) { break; } if (cur->intro_scope == scope) { break; } continue; } if (cur->items) { for (ULO i = cur->count; i > 0; i--) { const pl_binding *b = &cur->items[i - 1]; if ((b->scope == scope) && (b->var_id == var_id)) { found = b->value; break; } } if (found) { break; } } if (cur->intro_scope == scope) { break; } } if (found && (steps > 1)) { env_bind(env, rt_ctrl, dbg_dat_ptr, scope, var_id, found); } return found; } static void env_reserve(pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO extra) { if (!env->items && !env->cap) { env->items = env->local_items; env->cap = (ULO)FLOWLOG_ENV_LOCAL_BINDINGS; } if ((env->count + extra) <= env->cap) { return; } ULO new_cap = env->cap ? env->cap : 8; while (new_cap < (env->count + extra)) { new_cap *= 2; } pl_binding *new_items = (pl_binding *)pool_alloc(rt_ctrl, sizeof(pl_binding) * new_cap, dbg_dat_ptr); if (env->items && env->count) { memcpy(new_items, env->items, sizeof(pl_binding) * env->count); } env->items = new_items; env->cap = new_cap; } static void env_bind(pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_scope *scope, ULO var_id, pl_term *value) { env_reserve(env, rt_ctrl, dbg_dat_ptr, 1); env->items[env->count++] = (pl_binding){.scope = scope, .var_id = var_id, .value = value}; if (!env_map_maybe_rebuild(env, rt_ctrl, dbg_dat_ptr, 0)) { env_map_insert_raw(env->map, env->map_cap, scope, var_id, value); } } static void env_append(pl_env *dst, const pl_env *src, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!dst || !src) { return; } // Append full parent chain so catch/3 sees the same bindings as the throwing context. const pl_env *chain_local[256]; const pl_env **chain = chain_local; ULO chain_count = 0; ULO chain_cap = (ULO)(sizeof(chain_local) / sizeof(chain_local[0])); bool heap = false; for (const pl_env *cur = src; cur; cur = cur->parent) { if (chain_count == chain_cap) { ULO new_cap = chain_cap * 2; const pl_env **new_chain = (const pl_env **)realloc(heap ? (void *)chain : NULL, sizeof(*new_chain) * new_cap); if (!new_chain) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); break; } if (!heap && chain_count) { memcpy((void *)new_chain, chain, sizeof(*new_chain) * chain_count); } chain = new_chain; chain_cap = new_cap; heap = true; } chain[chain_count++] = cur; } ULO total = 0; for (ULO i = 0; i < chain_count; i++) { const pl_env *cur = chain[i]; if (cur && cur->items && cur->count) { total += cur->count; } } if (!total) { if (heap) { free((void *)chain); } return; } env_reserve(dst, rt_ctrl, dbg_dat_ptr, total); // Insert older bindings first, newer bindings last (to preserve overriding semantics). for (ULO i = chain_count; i > 0; i--) { const pl_env *cur = chain[i - 1]; if (!cur || !cur->items || !cur->count) { continue; } memcpy(dst->items + dst->count, cur->items, sizeof(pl_binding) * cur->count); dst->count += cur->count; } if (heap) { free((void *)chain); } env_map_rebuild(dst, rt_ctrl, dbg_dat_ptr, dst->count ? (dst->count * 2) : 16); } static pl_term *deref_term(pl_term *t, const pl_env *env) { while (t && (t->tag == PL_TERM_VAR)) { pl_term *v = env_lookup(env, t->v.var.scope, t->v.var.var_id); if (!v) { break; } // Avoid infinite loops if a variable is (incorrectly) bound to another node // representing the same logical variable. if (v->tag == PL_TERM_VAR && (v->v.var.scope == t->v.var.scope) && (v->v.var.var_id == t->v.var.var_id)) { break; } t = v; } return t; } static pl_term *deref_term_unify(pl_term *t, pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr) { while (t && (t->tag == PL_TERM_VAR)) { pl_term *v = env_lookup_cache_bind(env, t->v.var.scope, t->v.var.var_id, rt_ctrl, dbg_dat_ptr); if (!v) { break; } // Avoid infinite loops if a variable is (incorrectly) bound to another node // representing the same logical variable. if (v->tag == PL_TERM_VAR && (v->v.var.scope == t->v.var.scope) && (v->v.var.var_id == t->v.var.var_id)) { break; } t = v; } return t; } /* ============================================================================ * SECTION 14: Interpreter Term Ops & Unification * env bindings, unification, and subsumption checks (tree engine). * ============================================================================ */ /* --- SUBSECTION 14.1: Unification Entry Points --------------------------- */ // Unification entry points and env rollback helpers. // unify_terms() drives unification, env_rollback() rewinds bindings, and var_stack_init()/var_key_eq() manage visited vars. static bool unify_terms_occurs(pl_term *a, pl_term *b, pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr); static inline void env_rollback(pl_env *env, ULO count) { if (!env) { return; } env->count = count; // Binding rollback is count-based; invalidate derived lookup state. env->map = NULL; env->map_cap = 0; } typedef struct { pl_term *a; pl_term *b; } pl_unify_pair; static pl_unify_pair *unify_pair_vec_grow(pl_unify_pair *items, ULO count, ULO *cap, bool *heap, pl_unify_pair *local, ULO local_cap, const ULO *dbg_dat_ptr) { if (!cap || !heap) { return items; } ULO new_cap = *cap ? (*cap * 2) : local_cap; if (new_cap < 64) { new_cap = 64; } pl_unify_pair *new_items = NULL; if (!*heap) { new_items = (pl_unify_pair *)malloc(sizeof(pl_unify_pair) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } if (local && count) { memcpy(new_items, local, sizeof(pl_unify_pair) * count); } *heap = true; } else { new_items = (pl_unify_pair *)realloc(items, sizeof(pl_unify_pair) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } } *cap = new_cap; return new_items; } static bool unify_terms(pl_term *a, pl_term *b, pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (g_unify_occurs_check) { return unify_terms_occurs(a, b, env, rt_ctrl, dbg_dat_ptr); } const ULO save = env->count; pl_unify_pair stack_local[64]; pl_unify_pair seen_local[64]; pl_unify_pair *stack = stack_local; pl_unify_pair *seen = seen_local; ULO stack_count = 0; ULO seen_count = 0; ULO stack_cap = (ULO)(sizeof(stack_local) / sizeof(stack_local[0])); ULO seen_cap = (ULO)(sizeof(seen_local) / sizeof(seen_local[0])); bool stack_heap = false; bool seen_heap = false; stack[stack_count++] = (pl_unify_pair){.a = a, .b = b}; while (stack_count) { const pl_unify_pair p = stack[--stack_count]; pl_term *x = deref_term_unify(p.a, env, rt_ctrl, dbg_dat_ptr); pl_term *y = deref_term_unify(p.b, env, rt_ctrl, dbg_dat_ptr); x = deref_term_unify((pl_term *)term_peel_pstr_empty_const(x), env, rt_ctrl, dbg_dat_ptr); y = deref_term_unify((pl_term *)term_peel_pstr_empty_const(y), env, rt_ctrl, dbg_dat_ptr); if (x == y) { continue; } if (x && y && (x->tag == PL_TERM_VAR) && (y->tag == PL_TERM_VAR) && (x->v.var.scope == y->v.var.scope) && (x->v.var.var_id == y->v.var.var_id)) { // Same logical variable (different occurrences in the syntax tree). continue; } if (x && y && (x->tag == PL_TERM_VAR) && (y->tag == PL_TERM_VAR)) { // Prefer binding the RHS variable to the LHS variable. This keeps the left term's // variables stable (reduces alias-chain growth for workloads that repeatedly unify // with fresh variables, e.g. copy_term/2-driven comparisons in the INRIA harness). env_bind(env, rt_ctrl, dbg_dat_ptr, y->v.var.scope, y->v.var.var_id, x); continue; } if (x && (x->tag == PL_TERM_VAR)) { env_bind(env, rt_ctrl, dbg_dat_ptr, x->v.var.scope, x->v.var.var_id, y); continue; } if (y && (y->tag == PL_TERM_VAR)) { env_bind(env, rt_ctrl, dbg_dat_ptr, y->v.var.scope, y->v.var.var_id, x); continue; } if (!x || !y) { goto fail; } const bool xl = term_is_list_like_pair(x); const bool yl = term_is_list_like_pair(y); if (xl || yl) { // Treat packed strings as list-equivalent to '.'/2 lists. if (!xl || !yl) { goto fail; } if (!(term_is_list_pair(x) && term_is_list_pair(y))) { pl_term *xh = NULL; pl_term *xt = NULL; pl_term *yh = NULL; pl_term *yt = NULL; if (!term_list_like_uncons_rt(x, &xh, &xt, rt_ctrl, dbg_dat_ptr) || !term_list_like_uncons_rt(y, &yh, &yt, rt_ctrl, dbg_dat_ptr)) { goto fail; } if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = xt, .b = yt}; if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = xh, .b = yh}; continue; } } if (term_is_integer(x) || term_is_integer(y)) { if (!term_is_integer(x) || !term_is_integer(y) || !term_integer_equal(x, y)) { goto fail; } continue; } if (x->tag != y->tag) { goto fail; } switch (x->tag) { case PL_TERM_ATOM: if (strcmp(x->v.atom_name, y->v.atom_name)) { goto fail; } break; case PL_TERM_INT: if (x->v.int_value != y->v.int_value) { goto fail; } break; case PL_TERM_FLOAT: if (x->v.float_value != y->v.float_value) { goto fail; } break; case PL_TERM_VAR: break; case PL_TERM_STRUCT: { if ((x->v.str.arity != y->v.str.arity) || strcmp(x->v.str.functor, y->v.str.functor)) { goto fail; } // Cycle-safe rational-tree unification: avoid revisiting the same compound pair. pl_term *sx = x; pl_term *sy = y; if ((uintptr_t)sx > (uintptr_t)sy) { pl_term *tmp = sx; sx = sy; sy = tmp; } bool already = false; for (ULO i = 0; i < seen_count; i++) { if (seen[i].a == sx && seen[i].b == sy) { already = true; break; } } if (already) { break; } if (seen_count == seen_cap) { seen = unify_pair_vec_grow(seen, seen_count, &seen_cap, &seen_heap, seen_local, (ULO)(sizeof(seen_local) / sizeof(seen_local[0])), dbg_dat_ptr); } seen[seen_count++] = (pl_unify_pair){.a = sx, .b = sy}; // Push arguments in reverse so we process left-to-right (not required, but keeps behavior stable). for (ULO i = x->v.str.arity; i > 0; i--) { if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = x->v.str.args[i - 1], .b = y->v.str.args[i - 1]}; } break; } default: goto fail; } } if (stack_heap) { free(stack); } if (seen_heap) { free(seen); } return true; fail: env->count = save; // This env supports count-based rollback (used throughout unification). Any // auxiliary lookup structure must be invalidated when we rewind bindings. env->map = NULL; env->map_cap = 0; if (stack_heap) { free(stack); } if (seen_heap) { free(seen); } return false; } static pl_env *env_clone(const pl_env *src, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_env *dst = (pl_env *)pool_alloc(rt_ctrl, sizeof(*dst), dbg_dat_ptr); dst->parent = src; dst->intro_scope = NULL; dst->count = 0; dst->cap = (ULO)FLOWLOG_ENV_LOCAL_BINDINGS; dst->items = dst->local_items; dst->map_cap = 0; dst->map = NULL; return dst; } typedef struct { const pl_scope *scope; ULO var_id; } pl_var_key; static bool var_key_eq(pl_var_key a, pl_var_key b) { return (a.scope == b.scope) && (a.var_id == b.var_id); } typedef struct { pl_var_key *items; ULO count; ULO cap; } pl_var_stack; static void var_stack_init(pl_var_stack *st) { memset(st, 0, sizeof(*st)); } static void var_stack_free(pl_var_stack *st) { free(st->items); memset(st, 0, sizeof(*st)); } static bool var_stack_contains(const pl_var_stack *st, pl_var_key k) { for (ULO i = 0; i < st->count; i++) { if (var_key_eq(st->items[i], k)) { return true; } } return false; } static void var_stack_push(pl_var_stack *st, const ULO *dbg_dat_ptr, pl_var_key k) { if (st->count == st->cap) { ULO new_cap = st->cap ? (st->cap * 2) : 64; pl_var_key *new_items = (pl_var_key *)realloc(st->items, sizeof(pl_var_key) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } st->items = new_items; st->cap = new_cap; } st->items[st->count++] = k; } static void var_stack_pop(pl_var_stack *st) { if (st->count) { st->count--; } } typedef struct { pl_var_key key; pl_term *term; } pl_var_entry; typedef struct { pl_var_entry *items; ULO count; ULO cap; } pl_var_list; static void var_list_init(pl_var_list *vl) { memset(vl, 0, sizeof(*vl)); } static void var_list_free(pl_var_list *vl) { free(vl->items); memset(vl, 0, sizeof(*vl)); } typedef struct { pl_var_key key; ULO count; pl_term *term; } pl_var_count_entry; typedef struct { pl_var_count_entry *items; ULO count; ULO cap; } pl_var_count_list; static void var_count_list_init(pl_var_count_list *vl) { memset(vl, 0, sizeof(*vl)); } static void var_count_list_free(pl_var_count_list *vl) { free(vl->items); memset(vl, 0, sizeof(*vl)); } static pl_var_count_entry *var_count_list_find(pl_var_count_list *vl, pl_var_key k) { if (!vl) { return NULL; } for (ULO i = 0; i < vl->count; i++) { if (var_key_eq(vl->items[i].key, k)) { return &vl->items[i]; } } return NULL; } static void var_count_list_inc(pl_var_count_list *vl, const ULO *dbg_dat_ptr, pl_var_key k, pl_term *t) { if (!vl) { return; } pl_var_count_entry *e = var_count_list_find(vl, k); if (e) { e->count++; return; } if (vl->count == vl->cap) { ULO new_cap = vl->cap ? (vl->cap * 2) : 16; pl_var_count_entry *new_items = (pl_var_count_entry *)realloc(vl->items, sizeof(pl_var_count_entry) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } vl->items = new_items; vl->cap = new_cap; } vl->items[vl->count++] = (pl_var_count_entry){.key = k, .count = 1, .term = t}; } static void var_list_add_unique(pl_var_list *vl, const ULO *dbg_dat_ptr, pl_var_key k, pl_term *t) { for (ULO i = 0; i < vl->count; i++) { if (var_key_eq(vl->items[i].key, k)) { return; } } if (vl->count == vl->cap) { ULO new_cap = vl->cap ? (vl->cap * 2) : 64; pl_var_entry *new_items = (pl_var_entry *)realloc(vl->items, sizeof(pl_var_entry) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } vl->items = new_items; vl->cap = new_cap; } vl->items[vl->count++] = (pl_var_entry){.key = k, .term = t}; } static bool var_list_contains_key(const pl_var_list *vl, pl_var_key k) { if (!vl || !vl->items) { return false; } for (ULO i = 0; i < vl->count; i++) { if (var_key_eq(vl->items[i].key, k)) { return true; } } return false; } static pl_term *env_binding_for_var(const pl_env *env, const pl_term *var) { if (!var || (var->tag != PL_TERM_VAR)) { return NULL; } return env_lookup(env, var->v.var.scope, var->v.var.var_id); } static bool term_is_ground_tr(pl_term *t, const pl_env *env, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = env_binding_for_var(env, t); if (!b) { return false; } if (var_stack_contains(st, k)) { // Rational-tree cycle: no free variables introduced by re-visiting this var. return true; } var_stack_push(st, dbg_dat_ptr, k); bool ok = term_is_ground_tr(b, env, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (!tail) { return false; } return term_is_ground_tr(tail, env, st, dbg_dat_ptr, depth + 1); } if (term_is_atomic_term(t)) { return true; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { if (!term_is_ground_tr(t->v.str.args[i], env, st, dbg_dat_ptr, depth + 1)) { return false; } } return true; } return false; } static bool term_is_acyclic_tr(pl_term *t, const pl_env *env, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = env_binding_for_var(env, t); if (!b) { return true; } if (var_stack_contains(st, k)) { return false; } var_stack_push(st, dbg_dat_ptr, k); bool ok = term_is_acyclic_tr(b, env, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (!tail) { return false; } return term_is_acyclic_tr(tail, env, st, dbg_dat_ptr, depth + 1); } if (term_is_atomic_term(t)) { return true; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { if (!term_is_acyclic_tr(t->v.str.args[i], env, st, dbg_dat_ptr, depth + 1)) { return false; } } return true; } return false; } static void term_collect_vars_tr(pl_term *t, const pl_env *env, pl_var_stack *st, pl_var_list *out, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = env_binding_for_var(env, t); if (!b) { var_list_add_unique(out, dbg_dat_ptr, k, t); return; } if (var_stack_contains(st, k)) { return; } var_stack_push(st, dbg_dat_ptr, k); term_collect_vars_tr(b, env, st, out, dbg_dat_ptr, depth + 1); var_stack_pop(st); return; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (tail) { term_collect_vars_tr(tail, env, st, out, dbg_dat_ptr, depth + 1); } return; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { term_collect_vars_tr(t->v.str.args[i], env, st, out, dbg_dat_ptr, depth + 1); } } } static void term_count_vars_tr(pl_term *t, const pl_env *env, pl_var_stack *st, pl_var_count_list *out, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = env_binding_for_var(env, t); if (!b) { var_count_list_inc(out, dbg_dat_ptr, k, t); return; } if (var_stack_contains(st, k)) { return; } var_stack_push(st, dbg_dat_ptr, k); term_count_vars_tr(b, env, st, out, dbg_dat_ptr, depth + 1); var_stack_pop(st); return; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (tail) { term_count_vars_tr(tail, env, st, out, dbg_dat_ptr, depth + 1); } return; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { term_count_vars_tr(t->v.str.args[i], env, st, out, dbg_dat_ptr, depth + 1); } } } static bool term_numbervars_tr(pl_term *t, pl_env *env, pl_var_stack *st, SLO *counter, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!t || !env || !counter || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = env_binding_for_var(env, t); if (!b) { pl_term *nv = make_int_rt(rt_ctrl, dbg_dat_ptr, *counter); pl_term *sterm = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$VAR", 1); sterm->v.str.args[0] = nv; env_bind(env, rt_ctrl, dbg_dat_ptr, k.scope, k.var_id, sterm); (*counter)++; return true; } if (var_stack_contains(st, k)) { return true; } var_stack_push(st, dbg_dat_ptr, k); const bool ok = term_numbervars_tr(b, env, st, counter, rt_ctrl, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } t = deref_term(t, env); if (!t) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (!tail) { return true; } return term_numbervars_tr(tail, env, st, counter, rt_ctrl, dbg_dat_ptr, depth + 1); } if (term_is_atomic_term(t)) { return true; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { if (!term_numbervars_tr(t->v.str.args[i], env, st, counter, rt_ctrl, dbg_dat_ptr, depth + 1)) { return false; } } return true; } return true; } typedef struct { pl_var_key a; pl_var_key b; } pl_variant_pair; typedef struct { pl_variant_pair *items; ULO count; ULO cap; } pl_variant_map; static void variant_map_init(pl_variant_map *m) { memset(m, 0, sizeof(*m)); } static void variant_map_free(pl_variant_map *m) { free(m->items); memset(m, 0, sizeof(*m)); } static bool variant_map_lookup_a(const pl_variant_map *m, pl_var_key a, pl_var_key *out_b) { if (!m || !m->items) { return false; } for (ULO i = 0; i < m->count; i++) { if (var_key_eq(m->items[i].a, a)) { if (out_b) { *out_b = m->items[i].b; } return true; } } return false; } static bool variant_map_lookup_b(const pl_variant_map *m, pl_var_key b, pl_var_key *out_a) { if (!m || !m->items) { return false; } for (ULO i = 0; i < m->count; i++) { if (var_key_eq(m->items[i].b, b)) { if (out_a) { *out_a = m->items[i].a; } return true; } } return false; } static void variant_map_add(pl_variant_map *m, const ULO *dbg_dat_ptr, pl_var_key a, pl_var_key b) { if (m->count == m->cap) { ULO new_cap = m->cap ? (m->cap * 2) : 64; pl_variant_pair *new_items = (pl_variant_pair *)realloc(m->items, sizeof(pl_variant_pair) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } m->items = new_items; m->cap = new_cap; } m->items[m->count++] = (pl_variant_pair){.a = a, .b = b}; } static bool term_variant_tr(pl_term *a, pl_term *b, const pl_env *env, pl_var_stack *st_a, pl_var_stack *st_b, pl_variant_map *m, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } retry: if (a->tag == PL_TERM_VAR) { pl_var_key ka = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_term *ab = env_binding_for_var(env, a); if (ab && st_a && !var_stack_contains(st_a, ka)) { var_stack_push(st_a, dbg_dat_ptr, ka); bool ok = term_variant_tr(ab, b, env, st_a, st_b, m, dbg_dat_ptr, depth + 1); var_stack_pop(st_a); return ok; } } if (b->tag == PL_TERM_VAR) { pl_var_key kb = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_term *bb = env_binding_for_var(env, b); if (bb && st_b && !var_stack_contains(st_b, kb)) { var_stack_push(st_b, dbg_dat_ptr, kb); bool ok = term_variant_tr(a, bb, env, st_a, st_b, m, dbg_dat_ptr, depth + 1); var_stack_pop(st_b); return ok; } } pl_term *a_peel = (pl_term *)term_peel_pstr_empty_const(a); pl_term *b_peel = (pl_term *)term_peel_pstr_empty_const(b); if ((a_peel != a) || (b_peel != b)) { a = a_peel; b = b_peel; if (!a || !b) { return false; } goto retry; } const bool al = term_is_list_like_pair(a); const bool bl = term_is_list_like_pair(b); if (al || bl) { if (!al || !bl) { return false; } const pl_term *ah = NULL; const pl_term *at = NULL; const pl_term *bh = NULL; const pl_term *bt = NULL; pl_term a_head_tmp = {0}; CHR a_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term a_tail_tmp = {0}; pl_term b_head_tmp = {0}; CHR b_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term b_tail_tmp = {0}; if (!term_list_like_uncons_view(a, &ah, &at, &a_head_tmp, a_head_ch, &a_tail_tmp) || !term_list_like_uncons_view(b, &bh, &bt, &b_head_tmp, b_head_ch, &b_tail_tmp)) { return false; } return term_variant_tr((pl_term *)ah, (pl_term *)bh, env, st_a, st_b, m, dbg_dat_ptr, depth + 1) && term_variant_tr((pl_term *)at, (pl_term *)bt, env, st_a, st_b, m, dbg_dat_ptr, depth + 1); } if (term_is_integer(a) || term_is_integer(b)) { return term_is_integer(a) && term_is_integer(b) && term_integer_equal(a, b); } if (a->tag != b->tag) { return false; } switch (a->tag) { case PL_TERM_VAR: { pl_var_key ka = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_var_key kb = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_var_key mapped = {0}; if (variant_map_lookup_a(m, ka, &mapped)) { return var_key_eq(mapped, kb); } if (variant_map_lookup_b(m, kb, NULL)) { return false; } variant_map_add(m, dbg_dat_ptr, ka, kb); return true; } case PL_TERM_ATOM: return !strcmp(a->v.atom_name, b->v.atom_name); case PL_TERM_INT: return a->v.int_value == b->v.int_value; case PL_TERM_BIGINT: return term_integer_equal(a, b); case PL_TERM_FLOAT: return a->v.float_value == b->v.float_value; case PL_TERM_STRUCT: if ((a->v.str.arity != b->v.str.arity) || strcmp(a->v.str.functor, b->v.str.functor)) { return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!term_variant_tr(a->v.str.args[i], b->v.str.args[i], env, st_a, st_b, m, dbg_dat_ptr, depth + 1)) { return false; } } return true; default: break; } return false; } static bool term_variant_env(pl_term *a, pl_term *b, const pl_env *env, const ULO *dbg_dat_ptr) { pl_var_stack st_a; pl_var_stack st_b; pl_variant_map m = {0}; var_stack_init(&st_a); var_stack_init(&st_b); variant_map_init(&m); const bool ok = term_variant_tr(a, b, env, &st_a, &st_b, &m, dbg_dat_ptr, 0); variant_map_free(&m); var_stack_free(&st_b); var_stack_free(&st_a); return ok; } static bool term_occurs_var_tr(pl_var_key target, pl_term *t, const pl_env *env, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; if (var_key_eq(k, target)) { return true; } pl_term *b = env_binding_for_var(env, t); if (!b) { return false; } if (var_stack_contains(st, k)) { return false; } var_stack_push(st, dbg_dat_ptr, k); bool ok = term_occurs_var_tr(target, b, env, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } if (t->tag == PL_TERM_PSTR) { pl_term *tail = pstr_tail_term(t); return tail ? term_occurs_var_tr(target, tail, env, st, dbg_dat_ptr, depth + 1) : false; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { if (term_occurs_var_tr(target, t->v.str.args[i], env, st, dbg_dat_ptr, depth + 1)) { return true; } } } return false; } static inline pl_term *wam_binding_for_var(const pl_term *var); static bool term_occurs_var_wam_tr(pl_var_key target, pl_term *t, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; if (var_key_eq(k, target)) { return true; } pl_term *b = wam_binding_for_var(t); if (!b) { return false; } if (var_stack_contains(st, k)) { return false; } var_stack_push(st, dbg_dat_ptr, k); const bool ok = term_occurs_var_wam_tr(target, b, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } if (t->tag == PL_TERM_PSTR) { pl_term *tail = pstr_tail_term(t); return tail ? term_occurs_var_wam_tr(target, tail, st, dbg_dat_ptr, depth + 1) : false; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { if (term_occurs_var_wam_tr(target, t->v.str.args[i], st, dbg_dat_ptr, depth + 1)) { return true; } } } return false; } static bool unify_terms_occurs(pl_term *a, pl_term *b, pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr) { const ULO save = env->count; a = deref_term_unify(a, env, rt_ctrl, dbg_dat_ptr); b = deref_term_unify(b, env, rt_ctrl, dbg_dat_ptr); a = deref_term_unify((pl_term *)term_peel_pstr_empty_const(a), env, rt_ctrl, dbg_dat_ptr); b = deref_term_unify((pl_term *)term_peel_pstr_empty_const(b), env, rt_ctrl, dbg_dat_ptr); if (a == b) { return true; } if (a && b && (a->tag == PL_TERM_VAR) && (b->tag == PL_TERM_VAR) && (a->v.var.scope == b->v.var.scope) && (a->v.var.var_id == b->v.var.var_id)) { return true; } if (a && b && (a->tag == PL_TERM_VAR) && (b->tag == PL_TERM_VAR)) { // Var-var unification is always safe under occurs_check; keep the left variable stable. env_bind(env, rt_ctrl, dbg_dat_ptr, b->v.var.scope, b->v.var.var_id, a); return true; } if (a && (a->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_tr(k, b, env, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { env_rollback(env, save); return false; } env_bind(env, rt_ctrl, dbg_dat_ptr, a->v.var.scope, a->v.var.var_id, b); return true; } if (b && (b->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_tr(k, a, env, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { env_rollback(env, save); return false; } env_bind(env, rt_ctrl, dbg_dat_ptr, b->v.var.scope, b->v.var.var_id, a); return true; } if (!a || !b) { env_rollback(env, save); return false; } const bool al = term_is_list_like_pair(a); const bool bl = term_is_list_like_pair(b); if (al || bl) { // Treat packed strings as list-equivalent under occurs_check. if (!al || !bl) { env_rollback(env, save); return false; } if (!(term_is_list_pair(a) && term_is_list_pair(b))) { pl_term *ah = NULL; pl_term *at = NULL; pl_term *bh = NULL; pl_term *bt = NULL; if (!term_list_like_uncons_rt(a, &ah, &at, rt_ctrl, dbg_dat_ptr) || !term_list_like_uncons_rt(b, &bh, &bt, rt_ctrl, dbg_dat_ptr)) { env_rollback(env, save); return false; } if (!unify_terms_occurs(ah, bh, env, rt_ctrl, dbg_dat_ptr) || !unify_terms_occurs(at, bt, env, rt_ctrl, dbg_dat_ptr)) { env_rollback(env, save); return false; } return true; } } if (term_is_integer(a) || term_is_integer(b)) { if (!term_is_integer(a) || !term_is_integer(b) || !term_integer_equal(a, b)) { env_rollback(env, save); return false; } return true; } if (a->tag != b->tag) { env_rollback(env, save); return false; } switch (a->tag) { case PL_TERM_ATOM: if (!strcmp(a->v.atom_name, b->v.atom_name)) { return true; } env_rollback(env, save); return false; case PL_TERM_INT: if (a->v.int_value == b->v.int_value) { return true; } env_rollback(env, save); return false; case PL_TERM_BIGINT: if (term_integer_equal(a, b)) { return true; } env_rollback(env, save); return false; case PL_TERM_FLOAT: if (a->v.float_value == b->v.float_value) { return true; } env_rollback(env, save); return false; case PL_TERM_VAR: return true; case PL_TERM_STRUCT: if ((a->v.str.arity != b->v.str.arity) || strcmp(a->v.str.functor, b->v.str.functor)) { env_rollback(env, save); return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!unify_terms_occurs(a->v.str.args[i], b->v.str.args[i], env, rt_ctrl, dbg_dat_ptr)) { env_rollback(env, save); return false; } } return true; default: env_rollback(env, save); return false; } env_rollback(env, save); return false; } /* ============================================================================ * SECTION 15: WAM Term Ops & Arithmetic * trail-based unification and arithmetic evaluation for WAM. * ============================================================================ */ /* --- SUBSECTION 15.1: Trail-Based Unification ---------------------------- */ // Trail-based unification helpers for the WAM. // wam_trail_init()/wam_trail_push()/wam_trail_unwind() track and rewind bindings across backtracking. typedef struct { pl_wam_cell *cell; pl_term *old_value; } pl_wam_trail_entry; typedef struct { pl_wam_trail_entry *items; ULO count; ULO cap; } pl_wam_trail; static void wam_trail_init(pl_wam_trail *tr) { memset(tr, 0, sizeof(*tr)); } static void wam_trail_free(pl_wam_trail *tr) { if (!tr) { return; } free(tr->items); memset(tr, 0, sizeof(*tr)); } static void wam_trail_push(pl_wam_trail *tr, const ULO *dbg_dat_ptr, pl_wam_cell *cell) { if (!tr || !cell) { return; } if (tr->count == tr->cap) { ULO new_cap = tr->cap ? (tr->cap * 2) : 256; pl_wam_trail_entry *new_items = (pl_wam_trail_entry *)realloc(tr->items, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } tr->items = new_items; tr->cap = new_cap; } tr->items[tr->count++] = (pl_wam_trail_entry){.cell = cell, .old_value = cell->value}; } static void wam_trail_unwind(pl_wam_trail *tr, ULO mark) { if (!tr) { return; } while (tr->count > mark) { pl_wam_trail_entry e = tr->items[--tr->count]; if (e.cell) { e.cell->value = e.old_value; } } } typedef struct { const pl_scope *scope; pl_wam_cell *cells; // may be NULL when count==0 ULO count; } pl_wam_scope_cells; typedef struct { // 1-based scope id table; a variable's scope id is stored in pl_scope.reserved. pl_wam_scope_cells *scopes; // indexed [id-1] ULO scope_count; ULO scope_cap; // Query (top-level) scope id + cell array for env_to_sbuf_wam(). ULO q_scope_id; pl_wam_cell *q_cells; pl_wam_trail trail; const void *rt_ctrl; // allocator handle for term materialization during WAM unification } pl_wam_state; static FLOWLOG_TLS pl_wam_state *g_wam_state = NULL; typedef void (*pl_on_solution_wam_fn)(pl_wam_state *st, void *ctx, const void *rt_ctrl, const ULO *dbg_dat_ptr); static FLOWLOG_TLS pl_on_solution_wam_fn g_wam_on_solution = NULL; static FLOWLOG_TLS void *g_wam_on_solution_ctx = NULL; static void wam_state_scopes_reserve(pl_wam_state *st, ULO need, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)rt_ctrl; if (!st) { return; } if (need <= st->scope_cap) { return; } ULO new_cap = st->scope_cap ? st->scope_cap : 8; while (new_cap < need) { new_cap *= 2; } pl_wam_scope_cells *new_scopes = (pl_wam_scope_cells *)realloc(st->scopes, sizeof(*new_scopes) * new_cap); if (!new_scopes) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } if (new_cap > st->scope_cap) { memset(new_scopes + st->scope_cap, 0, sizeof(*new_scopes) * (new_cap - st->scope_cap)); } st->scopes = new_scopes; st->scope_cap = new_cap; } static void wam_state_push_scope_with_cells(pl_wam_state *st, pl_scope *scope, pl_wam_cell *cells, ULO cell_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!st || !scope) { return; } wam_state_scopes_reserve(st, st->scope_count + 1, rt_ctrl, dbg_dat_ptr); const ULO id = st->scope_count + 1; st->scopes[id - 1] = (pl_wam_scope_cells){.scope = scope, .cells = cells, .count = cell_count}; st->scope_count = id; scope->reserved = id; } static void wam_state_replace_top_scope_with_cells(pl_wam_state *st, pl_scope *scope, pl_wam_cell *cells, ULO cell_count) { if (!st || !scope || !st->scope_count) { return; } if (scope->reserved && scope->reserved != st->scope_count) { return; } const ULO id = st->scope_count; st->scopes[id - 1] = (pl_wam_scope_cells){.scope = scope, .cells = cells, .count = cell_count}; scope->reserved = id; } static pl_wam_cell *wam_state_push_scope(pl_wam_state *st, pl_scope *scope, ULO cell_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!st || !scope) { return NULL; } pl_wam_cell *cells = NULL; if (cell_count) { cells = (pl_wam_cell *)pool_alloc(rt_ctrl, sizeof(*cells) * cell_count, dbg_dat_ptr); memset(cells, 0, sizeof(*cells) * cell_count); } wam_state_push_scope_with_cells(st, scope, cells, cell_count, rt_ctrl, dbg_dat_ptr); return cells; } static void wam_state_pop_scope(pl_wam_state *st, const pl_scope *scope) { if (!st || !st->scope_count) { return; } if (scope) { const ULO id = scope->reserved; if (id && (id != st->scope_count)) { // Unexpected scope stack mismatch; keep state consistent rather than crashing. return; } } st->scope_count--; } static pl_term *build_select_relational_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *pred, pl_term *elem, pl_term *list, pl_term *rest) { pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); *scope = (pl_scope){.reserved = 0, .var_count = 3}; if (g_wam_state) { (void)wam_state_push_scope(g_wam_state, scope, 3, rt_ctrl, dbg_dat_ptr); } pl_term *x = make_var_rt(rt_ctrl, dbg_dat_ptr, scope, 0, "X"); pl_term *xs1 = make_var_rt(rt_ctrl, dbg_dat_ptr, scope, 1, "Xs"); pl_term *ys1 = make_var_rt(rt_ctrl, dbg_dat_ptr, scope, 2, "Ys"); pl_term *cons1 = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons1->v.str.args[0] = elem; cons1->v.str.args[1] = rest; pl_term *eq1 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); eq1->v.str.args[0] = list; eq1->v.str.args[1] = cons1; pl_term *cons2a = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons2a->v.str.args[0] = x; cons2a->v.str.args[1] = xs1; pl_term *eq2a = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); eq2a->v.str.args[0] = list; eq2a->v.str.args[1] = cons2a; pl_term *cons2b = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons2b->v.str.args[0] = x; cons2b->v.str.args[1] = ys1; pl_term *eq2b = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); eq2b->v.str.args[0] = rest; eq2b->v.str.args[1] = cons2b; const CHR *rec_name = pred ? pred : "select1"; pl_term *rec = make_struct_rt(rt_ctrl, dbg_dat_ptr, rec_name, 3); rec->v.str.args[0] = elem; rec->v.str.args[1] = xs1; rec->v.str.args[2] = ys1; pl_term *parts[3] = {eq2a, eq2b, rec}; pl_term *conj = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, parts, 3); pl_term *disj = make_struct_rt(rt_ctrl, dbg_dat_ptr, ";", 2); disj->v.str.args[0] = eq1; disj->v.str.args[1] = conj; return disj; } static void wam_state_clone_into(pl_wam_state *dst, const pl_wam_state *src, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!dst) { return; } memset(dst, 0, sizeof(*dst)); dst->rt_ctrl = rt_ctrl; if (!src || !src->scope_count || !src->scopes) { return; } wam_state_scopes_reserve(dst, src->scope_count, rt_ctrl, dbg_dat_ptr); dst->scope_count = src->scope_count; for (ULO i = 0; i < src->scope_count; i++) { dst->scopes[i].scope = src->scopes[i].scope; const ULO n = src->scopes[i].count; dst->scopes[i].count = n; if (n) { pl_wam_cell *cells = (pl_wam_cell *)pool_alloc(rt_ctrl, sizeof(*cells) * n, dbg_dat_ptr); memcpy(cells, src->scopes[i].cells, sizeof(*cells) * n); dst->scopes[i].cells = cells; } } dst->q_scope_id = src->q_scope_id; if (dst->q_scope_id >= 1 && dst->q_scope_id <= dst->scope_count) { dst->q_cells = dst->scopes[dst->q_scope_id - 1].cells; } wam_trail_init(&dst->trail); } static inline pl_wam_cell *wam_cell_for_var(const pl_term *t) { if (!t || (t->tag != PL_TERM_VAR)) { return NULL; } const pl_scope *s = t->v.var.scope; if (!s) { return NULL; } const ULO id = s->reserved; pl_wam_state *st = g_wam_state; if (!st || !id || id > st->scope_count || !st->scopes) { return NULL; } pl_wam_scope_cells *sc = &st->scopes[id - 1]; if (sc->scope != s) { return NULL; } if (!sc->cells || (t->v.var.var_id >= sc->count)) { return NULL; } return &sc->cells[t->v.var.var_id]; } static pl_term *deref_term_wam(pl_term *t) { while (t && (t->tag == PL_TERM_VAR)) { pl_wam_cell *cell = wam_cell_for_var(t); if (!cell || !cell->value) { break; } pl_term *v = cell->value; // Avoid infinite loops if a variable is (incorrectly) bound to itself. if (v == t) { break; } t = v; } return t; } static inline pl_term *wam_binding_for_var(const pl_term *var) { pl_wam_cell *cell = wam_cell_for_var(var); return (cell && cell->value) ? cell->value : NULL; } typedef struct { pl_binding *items; ULO count; ULO cap; } pl_binding_vec; static void binding_vec_init(pl_binding_vec *v) { memset(v, 0, sizeof(*v)); } static void binding_vec_free(pl_binding_vec *v) { free(v->items); memset(v, 0, sizeof(*v)); } static void binding_vec_push(pl_binding_vec *v, const ULO *dbg_dat_ptr, const pl_scope *scope, ULO var_id, pl_term *value) { if (!v) { return; } if (v->count == v->cap) { ULO new_cap = v->cap ? (v->cap * 2) : 32; pl_binding *new_items = (pl_binding *)realloc(v->items, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } v->items = new_items; v->cap = new_cap; } v->items[v->count++] = (pl_binding){.scope = scope, .var_id = var_id, .value = value}; } // Build a temporary env binding list for write_term_to_sbuf() by following WAM cell bindings // for variables reachable from the given term. This is only used for I/O built-ins, so it // favors simplicity over allocation-free design. static void wam_collect_bindings_for_write_tr(pl_term *t, pl_var_stack *seen, pl_binding_vec *out, const ULO *dbg_dat_ptr, ULO depth) { if (!t || !seen || !out || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; if (var_stack_contains(seen, k)) { return; } var_stack_push(seen, dbg_dat_ptr, k); pl_term *b = wam_binding_for_var(t); if (!b || b == t) { return; } binding_vec_push(out, dbg_dat_ptr, t->v.var.scope, t->v.var.var_id, b); wam_collect_bindings_for_write_tr(b, seen, out, dbg_dat_ptr, depth + 1); return; } if (t->tag == PL_TERM_STRUCT && t->v.str.args) { for (ULO i = 0; i < t->v.str.arity; i++) { wam_collect_bindings_for_write_tr(t->v.str.args[i], seen, out, dbg_dat_ptr, depth + 1); } } } static bool term_is_ground_wam_tr(pl_term *t, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = wam_binding_for_var(t); if (!b) { return false; } if (var_stack_contains(st, k)) { // Rational-tree cycle: no free variables introduced by re-visiting this var. return true; } var_stack_push(st, dbg_dat_ptr, k); const bool ok = term_is_ground_wam_tr(b, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (!tail) { return false; } return term_is_ground_wam_tr(tail, st, dbg_dat_ptr, depth + 1); } if (term_is_atomic_term(t)) { return true; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { if (!term_is_ground_wam_tr(t->v.str.args[i], st, dbg_dat_ptr, depth + 1)) { return false; } } return true; } return false; } static bool term_is_acyclic_wam_tr(pl_term *t, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = wam_binding_for_var(t); if (!b) { return true; } if (var_stack_contains(st, k)) { return false; } var_stack_push(st, dbg_dat_ptr, k); const bool ok = term_is_acyclic_wam_tr(b, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (!tail) { return false; } return term_is_acyclic_wam_tr(tail, st, dbg_dat_ptr, depth + 1); } if (term_is_atomic_term(t)) { return true; } if (t->tag == PL_TERM_STRUCT) { for (ULO i = 0; i < t->v.str.arity; i++) { if (!term_is_acyclic_wam_tr(t->v.str.args[i], st, dbg_dat_ptr, depth + 1)) { return false; } } return true; } return false; } static void term_collect_vars_wam_tr(pl_term *t, pl_var_stack *st, pl_var_list *out, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = wam_binding_for_var(t); if (!b) { var_list_add_unique(out, dbg_dat_ptr, k, t); return; } if (var_stack_contains(st, k)) { return; } var_stack_push(st, dbg_dat_ptr, k); term_collect_vars_wam_tr(b, st, out, dbg_dat_ptr, depth + 1); var_stack_pop(st); return; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (tail) { term_collect_vars_wam_tr(tail, st, out, dbg_dat_ptr, depth + 1); } return; } if (t->tag == PL_TERM_STRUCT && t->v.str.args) { for (ULO i = 0; i < t->v.str.arity; i++) { term_collect_vars_wam_tr(t->v.str.args[i], st, out, dbg_dat_ptr, depth + 1); } } } static inline bool wam_bind_var(pl_term *var, pl_term *value, pl_wam_trail *trail, const ULO *dbg_dat_ptr); static bool term_numbervars_wam_tr(pl_term *t, pl_var_stack *st, SLO *counter, pl_wam_trail *trail, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!t || !counter || !trail || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_term *b = wam_binding_for_var(t); if (!b) { pl_term *nv = make_int_rt(rt_ctrl, dbg_dat_ptr, *counter); pl_term *sterm = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$VAR", 1); sterm->v.str.args[0] = nv; if (!wam_bind_var(t, sterm, trail, dbg_dat_ptr)) { return false; } (*counter)++; return true; } if (var_stack_contains(st, k)) { return true; } var_stack_push(st, dbg_dat_ptr, k); const bool ok = term_numbervars_wam_tr(b, st, counter, trail, rt_ctrl, dbg_dat_ptr, depth + 1); var_stack_pop(st); return ok; } t = deref_term_wam(t); if (!t) { return false; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return false; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { pl_term *tail = pstr_tail_term(t); if (!tail) { return true; } return term_numbervars_wam_tr(tail, st, counter, trail, rt_ctrl, dbg_dat_ptr, depth + 1); } if (term_is_atomic_term(t)) { return true; } if (t->tag == PL_TERM_STRUCT && t->v.str.args) { for (ULO i = 0; i < t->v.str.arity; i++) { if (!term_numbervars_wam_tr(t->v.str.args[i], st, counter, trail, rt_ctrl, dbg_dat_ptr, depth + 1)) { return false; } } return true; } return true; } static inline bool wam_same_var(const pl_term *a, const pl_term *b) { if (!a || !b || (a->tag != PL_TERM_VAR) || (b->tag != PL_TERM_VAR)) { return false; } return (a->v.var.scope == b->v.var.scope) && (a->v.var.var_id == b->v.var.var_id); } static inline bool wam_bind_var(pl_term *var, pl_term *value, pl_wam_trail *trail, const ULO *dbg_dat_ptr) { if (!var || (var->tag != PL_TERM_VAR)) { return false; } pl_wam_cell *cell = wam_cell_for_var(var); if (!cell) { // WAM engine requires variables to have been pre-wired to a cell. return false; } if (cell->value) { return true; // already bound (should be deref'd before binding) } wam_trail_push(trail, dbg_dat_ptr, cell); cell->value = value; return true; } static inline bool wam_unify_pstr_list_pair(pl_term *pstr, pl_term *list_pair, pl_wam_trail *trail, const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term **out_pstr_tail, pl_term **out_list_tail) { if (!pstr || !list_pair || !out_pstr_tail || !out_list_tail) { return false; } if (!term_is_pstr_nonempty(pstr) || !term_is_list_pair(list_pair) || !list_pair->v.str.args) { return false; } pl_term *h = list_pair->v.str.args[0]; if (h && h->tag == PL_TERM_VAR) { h = deref_term_wam(h); } if (!h) { return false; } const unsigned char *bytes = pstr->v.pstr.bytes; if (!bytes) { return false; } size_t used = 0; uint32_t cp = 0; if (bytes[0] < 0x80) { if (h->tag == PL_TERM_ATOM) { const unsigned char *name = (const unsigned char *)h->v.atom_name; if (!name || !name[0]) { return false; } if (name[1] == 0) { if (bytes[0] != name[0]) { return false; } used = 1; goto pstr_list_tail; } } cp = bytes[0]; used = 1; } else { used = pstr_decode_one(bytes, &cp); if (!used) { return false; } } if (h->tag == PL_TERM_VAR) { pl_term *ch = make_char_atom_rt(dbg_dat_ptr, cp); if (!wam_bind_var(h, ch, trail, dbg_dat_ptr)) { return false; } } else if (h->tag == PL_TERM_ATOM) { uint32_t hcp = 0; if (!atom_codepoint(h, &hcp) || (hcp != cp)) { return false; } } else { return false; } pstr_list_tail: *out_list_tail = list_pair->v.str.args[1]; *out_pstr_tail = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, pstr, (ULO)used); return true; } static inline bool wam_unify_pstr_pstr_fast(pl_term *a, pl_term *b, const void *rt_ctrl, const ULO *dbg_dat_ptr, pl_term **out_a, pl_term **out_b, bool *out_done) { if (!a || !b || !out_a || !out_b || !out_done) { return false; } *out_a = NULL; *out_b = NULL; *out_done = false; pl_term *ca = a; pl_term *cb = b; for (ULO guard = 0; guard < 65536; guard++) { if (!term_is_pstr_nonempty(ca) || !term_is_pstr_nonempty(cb)) { *out_a = ca; *out_b = cb; return true; } const unsigned char *ab = ca->v.pstr.bytes; const unsigned char *bb = cb->v.pstr.bytes; if (!ab || !bb) { return false; } const size_t alen = pstr_run_len_bytes(ab); const size_t blen = pstr_run_len_bytes(bb); const size_t minlen = (alen < blen) ? alen : blen; if (minlen && memcmp(ab, bb, minlen)) { return false; } if (alen == blen) { pl_term *atail = pstr_tail_term_from_nul(ab + alen); pl_term *btail = pstr_tail_term_from_nul(bb + blen); if (!atail || !btail) { return false; } ca = (pl_term *)term_peel_pstr_empty_const(atail); cb = (pl_term *)term_peel_pstr_empty_const(btail); if (ca == cb) { *out_done = true; return true; } if (!term_is_pstr_nonempty(ca) || !term_is_pstr_nonempty(cb)) { *out_a = ca; *out_b = cb; return true; } continue; } if (alen < blen) { pl_term *atail = pstr_tail_term_from_nul(ab + alen); if (!atail) { return false; } pl_term *brem = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, cb, (ULO)alen); *out_a = (pl_term *)term_peel_pstr_empty_const(atail); *out_b = brem; return true; } pl_term *btail = pstr_tail_term_from_nul(bb + blen); if (!btail) { return false; } pl_term *arem = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, ca, (ULO)blen); *out_a = arem; *out_b = (pl_term *)term_peel_pstr_empty_const(btail); return true; } return false; } static bool unify_terms_wam_occurs(pl_term *a, pl_term *b, pl_wam_trail *trail, const ULO *dbg_dat_ptr); static bool unify_terms_wam(pl_term *a, pl_term *b, pl_wam_trail *trail, const ULO *dbg_dat_ptr) { if (g_unify_occurs_check) { return unify_terms_wam_occurs(a, b, trail, dbg_dat_ptr); } const ULO save = trail ? trail->count : 0; const void *rt_ctrl = g_wam_state ? g_wam_state->rt_ctrl : NULL; pl_unify_pair stack_local[64]; pl_unify_pair seen_local[64]; pl_unify_pair *stack = stack_local; pl_unify_pair *seen = seen_local; ULO stack_count = 0; ULO seen_count = 0; ULO stack_cap = (ULO)(sizeof(stack_local) / sizeof(stack_local[0])); ULO seen_cap = (ULO)(sizeof(seen_local) / sizeof(seen_local[0])); bool stack_heap = false; bool seen_heap = false; stack[stack_count++] = (pl_unify_pair){.a = a, .b = b}; while (stack_count) { const pl_unify_pair p = stack[--stack_count]; pl_term *x = deref_term_wam(p.a); pl_term *y = deref_term_wam(p.b); if (x && x->tag == PL_TERM_PSTR) { const pl_term *px = term_peel_pstr_empty_const(x); if (px != x) { x = deref_term_wam((pl_term *)px); } } if (y && y->tag == PL_TERM_PSTR) { const pl_term *py = term_peel_pstr_empty_const(y); if (py != y) { y = deref_term_wam((pl_term *)py); } } if (x == y) { continue; } if (wam_same_var(x, y)) { continue; } if (x && (x->tag == PL_TERM_VAR)) { if (!wam_bind_var(x, y, trail, dbg_dat_ptr)) { goto fail; } continue; } if (y && (y->tag == PL_TERM_VAR)) { if (!wam_bind_var(y, x, trail, dbg_dat_ptr)) { goto fail; } continue; } if (!x || !y) { goto fail; } const bool xl = term_is_list_like_pair(x); const bool yl = term_is_list_like_pair(y); if (xl || yl) { // Treat packed strings as list-equivalent to '.'/2 lists. if (!xl || !yl) { goto fail; } if (term_is_pstr_nonempty(x) && term_is_pstr_nonempty(y)) { pl_term *xt = NULL; pl_term *yt = NULL; bool done = false; if (!wam_unify_pstr_pstr_fast(x, y, rt_ctrl, dbg_dat_ptr, &xt, &yt, &done)) { goto fail; } if (done) { continue; } if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = xt, .b = yt}; continue; } if (term_is_pstr_nonempty(x) && term_is_list_pair(y)) { pl_term *xt = NULL; pl_term *yt = NULL; if (!wam_unify_pstr_list_pair(x, y, trail, rt_ctrl, dbg_dat_ptr, &xt, &yt)) { goto fail; } if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = xt, .b = yt}; continue; } if (term_is_pstr_nonempty(y) && term_is_list_pair(x)) { pl_term *yt = NULL; pl_term *xt = NULL; if (!wam_unify_pstr_list_pair(y, x, trail, rt_ctrl, dbg_dat_ptr, &yt, &xt)) { goto fail; } if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = xt, .b = yt}; continue; } if (!(term_is_list_pair(x) && term_is_list_pair(y))) { pl_term *xh = NULL; pl_term *xt = NULL; pl_term *yh = NULL; pl_term *yt = NULL; if (!term_list_like_uncons_rt(x, &xh, &xt, rt_ctrl, dbg_dat_ptr) || !term_list_like_uncons_rt(y, &yh, &yt, rt_ctrl, dbg_dat_ptr)) { goto fail; } if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = xt, .b = yt}; if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = xh, .b = yh}; continue; } } if (term_is_integer(x) || term_is_integer(y)) { if (!term_is_integer(x) || !term_is_integer(y) || !term_integer_equal(x, y)) { goto fail; } continue; } if (x->tag != y->tag) { goto fail; } switch (x->tag) { case PL_TERM_ATOM: if (strcmp(x->v.atom_name, y->v.atom_name)) { goto fail; } break; case PL_TERM_INT: if (x->v.int_value != y->v.int_value) { goto fail; } break; case PL_TERM_FLOAT: if (x->v.float_value != y->v.float_value) { goto fail; } break; case PL_TERM_VAR: break; case PL_TERM_STRUCT: { if ((x->v.str.arity != y->v.str.arity) || strcmp(x->v.str.functor, y->v.str.functor)) { goto fail; } // Cycle-safe rational-tree unification: avoid revisiting the same compound pair. pl_term *sx = x; pl_term *sy = y; if ((uintptr_t)sx > (uintptr_t)sy) { pl_term *tmp = sx; sx = sy; sy = tmp; } bool already = false; for (ULO i = 0; i < seen_count; i++) { if (seen[i].a == sx && seen[i].b == sy) { already = true; break; } } if (already) { break; } if (seen_count == seen_cap) { seen = unify_pair_vec_grow(seen, seen_count, &seen_cap, &seen_heap, seen_local, (ULO)(sizeof(seen_local) / sizeof(seen_local[0])), dbg_dat_ptr); } seen[seen_count++] = (pl_unify_pair){.a = sx, .b = sy}; // Push arguments in reverse so we process left-to-right (not required, but keeps behavior stable). for (ULO i = x->v.str.arity; i > 0; i--) { if (stack_count == stack_cap) { stack = unify_pair_vec_grow(stack, stack_count, &stack_cap, &stack_heap, stack_local, (ULO)(sizeof(stack_local) / sizeof(stack_local[0])), dbg_dat_ptr); } stack[stack_count++] = (pl_unify_pair){.a = x->v.str.args[i - 1], .b = y->v.str.args[i - 1]}; } break; } default: goto fail; } } if (stack_heap) { free(stack); } if (seen_heap) { free(seen); } return true; fail: if (trail) { wam_trail_unwind(trail, save); } if (stack_heap) { free(stack); } if (seen_heap) { free(seen); } return false; } static bool unify_terms_wam_occurs(pl_term *a, pl_term *b, pl_wam_trail *trail, const ULO *dbg_dat_ptr) { const ULO save = trail ? trail->count : 0; const void *rt_ctrl = g_wam_state ? g_wam_state->rt_ctrl : NULL; a = deref_term_wam(a); b = deref_term_wam(b); if (a && a->tag == PL_TERM_PSTR) { const pl_term *ap = term_peel_pstr_empty_const(a); if (ap != a) { a = deref_term_wam((pl_term *)ap); } } if (b && b->tag == PL_TERM_PSTR) { const pl_term *bp = term_peel_pstr_empty_const(b); if (bp != b) { b = deref_term_wam((pl_term *)bp); } } if (a == b) { return true; } if (a && b && (a->tag == PL_TERM_VAR) && (b->tag == PL_TERM_VAR) && (a->v.var.scope == b->v.var.scope) && (a->v.var.var_id == b->v.var.var_id)) { return true; } if (a && b && (a->tag == PL_TERM_VAR) && (b->tag == PL_TERM_VAR)) { // Var-var unification is always safe under occurs_check; keep the left variable stable. if (!wam_bind_var(b, a, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } if (a && (a->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_wam_tr(k, b, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { wam_trail_unwind(trail, save); return false; } if (!wam_bind_var(a, b, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } if (b && (b->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_wam_tr(k, a, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { wam_trail_unwind(trail, save); return false; } if (!wam_bind_var(b, a, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } if (!a || !b) { wam_trail_unwind(trail, save); return false; } const bool al = term_is_list_like_pair(a); const bool bl = term_is_list_like_pair(b); if (al || bl) { // Treat packed strings as list-equivalent under occurs_check. if (!al || !bl) { wam_trail_unwind(trail, save); return false; } if (term_is_pstr_nonempty(a) && term_is_pstr_nonempty(b)) { pl_term *at = NULL; pl_term *bt = NULL; bool done = false; if (!wam_unify_pstr_pstr_fast(a, b, rt_ctrl, dbg_dat_ptr, &at, &bt, &done)) { wam_trail_unwind(trail, save); return false; } if (done) { return true; } if (!unify_terms_wam_occurs(at, bt, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } if (term_is_pstr_nonempty(a) && term_is_list_pair(b)) { pl_term *at = NULL; pl_term *bt = NULL; if (!wam_unify_pstr_list_pair(a, b, trail, rt_ctrl, dbg_dat_ptr, &at, &bt)) { wam_trail_unwind(trail, save); return false; } if (!unify_terms_wam_occurs(at, bt, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } if (term_is_pstr_nonempty(b) && term_is_list_pair(a)) { pl_term *bt = NULL; pl_term *at = NULL; if (!wam_unify_pstr_list_pair(b, a, trail, rt_ctrl, dbg_dat_ptr, &bt, &at)) { wam_trail_unwind(trail, save); return false; } if (!unify_terms_wam_occurs(at, bt, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } if (!(term_is_list_pair(a) && term_is_list_pair(b))) { pl_term *ah = NULL; pl_term *at = NULL; pl_term *bh = NULL; pl_term *bt = NULL; if (!term_list_like_uncons_rt(a, &ah, &at, rt_ctrl, dbg_dat_ptr) || !term_list_like_uncons_rt(b, &bh, &bt, rt_ctrl, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } if (!unify_terms_wam_occurs(ah, bh, trail, dbg_dat_ptr) || !unify_terms_wam_occurs(at, bt, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } } if (term_is_integer(a) || term_is_integer(b)) { if (!term_is_integer(a) || !term_is_integer(b) || !term_integer_equal(a, b)) { wam_trail_unwind(trail, save); return false; } return true; } if (a->tag != b->tag) { wam_trail_unwind(trail, save); return false; } switch (a->tag) { case PL_TERM_ATOM: if (!strcmp(a->v.atom_name, b->v.atom_name)) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_INT: if (a->v.int_value == b->v.int_value) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_BIGINT: if (term_integer_equal(a, b)) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_FLOAT: if (a->v.float_value == b->v.float_value) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_VAR: return true; case PL_TERM_STRUCT: if ((a->v.str.arity != b->v.str.arity) || strcmp(a->v.str.functor, b->v.str.functor)) { wam_trail_unwind(trail, save); return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!unify_terms_wam_occurs(a->v.str.args[i], b->v.str.args[i], trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } } return true; default: wam_trail_unwind(trail, save); return false; } wam_trail_unwind(trail, save); return false; } static bool unify_terms_subsumes_wam_tr(pl_term *a, pl_term *b, pl_wam_trail *trail, const pl_var_list *rigid, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth); static bool unify_terms_subsumes_wam_tr_listlike_fast(pl_term *a, pl_term *b, pl_wam_trail *trail, const pl_var_list *rigid, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b || !trail || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } pl_term *ca = a; pl_term *cb = b; ULO a_off = 0; ULO b_off = 0; for (ULO guard = 0; !FLOWLOG_DEPTH_LIMIT_REACHED(guard, FLOWLOG_SOLVE_DEPTH_LIMIT); guard++) { ca = deref_term_wam(ca); cb = deref_term_wam(cb); ca = deref_term_wam((pl_term *)term_peel_pstr_empty_const(ca)); cb = deref_term_wam((pl_term *)term_peel_pstr_empty_const(cb)); if (!ca || !cb) { return false; } // If we are in the middle of a packed run, and the offset reached its NUL terminator, // advance to the run tail and continue (no slice allocations). if (ca->tag == PL_TERM_PSTR && ca->v.pstr.bytes) { while (ca->v.pstr.bytes[a_off] == 0) { pl_term *tail = pstr_tail_term_from_nul(ca->v.pstr.bytes + a_off); if (!tail) { return false; } ca = tail; a_off = 0; ca = deref_term_wam(ca); ca = deref_term_wam((pl_term *)term_peel_pstr_empty_const(ca)); if (!ca || ca->tag != PL_TERM_PSTR || !ca->v.pstr.bytes) { break; } } } else { a_off = 0; } if (cb->tag == PL_TERM_PSTR && cb->v.pstr.bytes) { while (cb->v.pstr.bytes[b_off] == 0) { pl_term *tail = pstr_tail_term_from_nul(cb->v.pstr.bytes + b_off); if (!tail) { return false; } cb = tail; b_off = 0; cb = deref_term_wam(cb); cb = deref_term_wam((pl_term *)term_peel_pstr_empty_const(cb)); if (!cb || cb->tag != PL_TERM_PSTR || !cb->v.pstr.bytes) { break; } } } else { b_off = 0; } const bool ca_pstr = term_is_pstr_nonempty(ca); const bool cb_pstr = term_is_pstr_nonempty(cb); const bool ca_list = term_is_list_pair(ca); const bool cb_list = term_is_list_pair(cb); if (!(ca_pstr || ca_list) || !(cb_pstr || cb_list)) { pl_term *a_rem = ca; pl_term *b_rem = cb; if (ca_pstr && a_off) { a_rem = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, ca, a_off); } if (cb_pstr && b_off) { b_rem = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, cb, b_off); } return unify_terms_subsumes_wam_tr(a_rem, b_rem, trail, rigid, rt_ctrl, dbg_dat_ptr, depth + 1); } if (ca_pstr && cb_pstr) { const unsigned char *ap = ca->v.pstr.bytes + a_off; const unsigned char *bp = cb->v.pstr.bytes + b_off; while (*ap && *bp) { uint32_t acp = 0; uint32_t bcp = 0; const size_t aused = pstr_decode_one(ap, &acp); const size_t bused = pstr_decode_one(bp, &bcp); if (!aused || !bused || acp != bcp) { break; } ap += aused; bp += bused; } a_off = (ULO)(ap - ca->v.pstr.bytes); b_off = (ULO)(bp - cb->v.pstr.bytes); if (*ap && *bp) { return false; // mismatch } if (*ap == 0) { pl_term *atail = pstr_tail_term_from_nul(ap); if (!atail) { return false; } ca = atail; a_off = 0; } if (*bp == 0) { pl_term *btail = pstr_tail_term_from_nul(bp); if (!btail) { return false; } cb = btail; b_off = 0; } continue; } if (ca_pstr) { uint32_t ch = 0; const unsigned char *ap = ca->v.pstr.bytes + a_off; const size_t used = pstr_decode_one(ap, &ch); if (!used) { return false; } pl_term *char_atom = make_char_atom_rt(dbg_dat_ptr, ch); pl_term *bh = cb->v.str.args[0]; if (!unify_terms_subsumes_wam_tr(char_atom, bh, trail, rigid, rt_ctrl, dbg_dat_ptr, depth + 1)) { return false; } a_off += (ULO)used; cb = cb->v.str.args[1]; continue; } // cb_pstr uint32_t ch = 0; const unsigned char *bp = cb->v.pstr.bytes + b_off; const size_t used = pstr_decode_one(bp, &ch); if (!used) { return false; } pl_term *char_atom = make_char_atom_rt(dbg_dat_ptr, ch); pl_term *ah = ca->v.str.args[0]; if (!unify_terms_subsumes_wam_tr(ah, char_atom, trail, rigid, rt_ctrl, dbg_dat_ptr, depth + 1)) { return false; } b_off += (ULO)used; ca = ca->v.str.args[1]; } return false; } static bool unify_terms_subsumes_wam_tr(pl_term *a, pl_term *b, pl_wam_trail *trail, const pl_var_list *rigid, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b || !trail || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } const ULO save = trail->count; a = deref_term_wam(a); b = deref_term_wam(b); a = deref_term_wam((pl_term *)term_peel_pstr_empty_const(a)); b = deref_term_wam((pl_term *)term_peel_pstr_empty_const(b)); if (a == b) { return true; } if (a->tag == PL_TERM_VAR) { pl_var_key k = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; if (var_list_contains_key(rigid, k)) { wam_trail_unwind(trail, save); return false; } pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_wam_tr(k, b, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { wam_trail_unwind(trail, save); return false; } if (!wam_bind_var(a, b, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } if (b->tag == PL_TERM_VAR) { pl_var_key k = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; if (var_list_contains_key(rigid, k)) { wam_trail_unwind(trail, save); return false; } pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_wam_tr(k, a, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { wam_trail_unwind(trail, save); return false; } if (!wam_bind_var(b, a, trail, dbg_dat_ptr)) { wam_trail_unwind(trail, save); return false; } return true; } const bool al = term_is_list_like_pair(a); const bool bl = term_is_list_like_pair(b); if (al || bl) { // Treat packed strings as list-equivalent for subsumption. if (!al || !bl) { wam_trail_unwind(trail, save); return false; } if (!(term_is_list_pair(a) && term_is_list_pair(b))) { if (!unify_terms_subsumes_wam_tr_listlike_fast(a, b, trail, rigid, rt_ctrl, dbg_dat_ptr, depth)) { wam_trail_unwind(trail, save); return false; } return true; } } if (term_is_integer(a) || term_is_integer(b)) { if (!term_is_integer(a) || !term_is_integer(b) || !term_integer_equal(a, b)) { wam_trail_unwind(trail, save); return false; } return true; } if (a->tag != b->tag) { wam_trail_unwind(trail, save); return false; } switch (a->tag) { case PL_TERM_ATOM: if (!strcmp(a->v.atom_name, b->v.atom_name)) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_INT: if (a->v.int_value == b->v.int_value) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_BIGINT: if (term_integer_equal(a, b)) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_FLOAT: if (a->v.float_value == b->v.float_value) { return true; } wam_trail_unwind(trail, save); return false; case PL_TERM_VAR: return true; case PL_TERM_STRUCT: if ((a->v.str.arity != b->v.str.arity) || strcmp(a->v.str.functor, b->v.str.functor)) { wam_trail_unwind(trail, save); return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!unify_terms_subsumes_wam_tr(a->v.str.args[i], b->v.str.args[i], trail, rigid, rt_ctrl, dbg_dat_ptr, depth + 1)) { wam_trail_unwind(trail, save); return false; } } return true; default: wam_trail_unwind(trail, save); return false; } wam_trail_unwind(trail, save); return false; } /* --- SUBSECTION 15.2: Arithmetic Evaluation & Numeric Core --------------- */ // Numeric core: SLO integers promote to heap bigints as needed. // Bigints use base-2^32 limbs (little-endian) with sign in {-1,0,1} and no leading zero limbs. #define BIGINT_BASE_BITS 32 #define BIGINT_BASE ((uint64_t)1u << BIGINT_BASE_BITS) struct pl_bigint { int sign; // -1, 0, +1 ULO len; uint32_t limbs[]; }; typedef struct { uint32_t *buf1; uint32_t *buf2; ULO cap1; ULO cap2; } pl_bigint_scratch; static FLOWLOG_TLS pl_bigint_scratch g_bigint_scratch = {0}; static uint32_t *bigint_scratch_reserve(uint32_t **buf, ULO *cap, ULO need) { if (!buf || !cap || need == 0) { return NULL; } if (*buf && (*cap >= need)) { return *buf; } ULO new_cap = *cap ? *cap : 8; while (new_cap < need) { new_cap *= 2; } uint32_t *next = (uint32_t *)realloc(*buf, sizeof(uint32_t) * new_cap); if (!next) { return NULL; } *buf = next; *cap = new_cap; return next; } static pl_bigint *bigint_alloc(const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO len) { pl_bigint *b = (pl_bigint *)pool_alloc(rt_ctrl, sizeof(*b) + (sizeof(uint32_t) * len), dbg_dat_ptr); b->sign = 0; b->len = len; if (len) { memset(b->limbs, 0, sizeof(uint32_t) * len); } return b; } static void bigint_normalize(pl_bigint *b) { if (!b) { return; } while (b->len > 0 && b->limbs[b->len - 1] == 0) { b->len--; } if (b->len == 0) { b->sign = 0; } } static bool bigint_is_zero(const pl_bigint *b) { return !b || b->len == 0 || b->sign == 0; } static pl_bigint *bigint_copy(const pl_bigint *src, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!src || src->len == 0 || src->sign == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, src->len); out->len = src->len; out->sign = src->sign; memcpy(out->limbs, src->limbs, sizeof(uint32_t) * src->len); return out; } static pl_bigint *bigint_from_slo(const void *rt_ctrl, const ULO *dbg_dat_ptr, SLO v) { if (v == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } uint64_t mag = 0; int sign = 1; if (v < 0) { sign = -1; mag = (uint64_t)(-(v + 1)) + 1; } else { mag = (uint64_t)v; } ULO len = (mag > UINT32_MAX) ? 2 : 1; pl_bigint *b = bigint_alloc(rt_ctrl, dbg_dat_ptr, len); b->sign = sign; b->limbs[0] = (uint32_t)(mag & 0xffffffffu); if (len > 1) { b->limbs[1] = (uint32_t)(mag >> 32); } return b; } static ULO bigint_bit_length_abs(const pl_bigint *b) { if (!b || b->len == 0) { return 0; } const uint32_t top = b->limbs[b->len - 1]; if (!top) { return 0; } #if defined(__has_builtin) # if __has_builtin(__builtin_clz) const int leading = __builtin_clz(top); # else int leading = 0; uint32_t v = top; while ((v & 0x80000000u) == 0) { leading++; v <<= 1; } # endif #else int leading = 0; uint32_t v = top; while ((v & 0x80000000u) == 0) { leading++; v <<= 1; } #endif return (ULO)(b->len - 1) * BIGINT_BASE_BITS + (ULO)(32 - leading); } static int bigint_cmp_abs(const pl_bigint *a, const pl_bigint *b) { const ULO alen = a ? a->len : 0; const ULO blen = b ? b->len : 0; if (alen != blen) { return (alen > blen) ? 1 : -1; } for (ULO i = alen; i > 0; i--) { const uint32_t av = a->limbs[i - 1]; const uint32_t bv = b->limbs[i - 1]; if (av != bv) { return (av > bv) ? 1 : -1; } } return 0; } static int bigint_cmp_abs_slo(const pl_bigint *a, SLO b) { if (!a || a->len == 0) { return b == 0 ? 0 : -1; } uint64_t mag = 0; if (b < 0) { mag = (uint64_t)(-(b + 1)) + 1; } else { mag = (uint64_t)b; } uint32_t m0 = (uint32_t)(mag & 0xffffffffu); uint32_t m1 = (uint32_t)(mag >> 32); ULO blen = m1 ? 2 : (m0 ? 1 : 0); if (a->len != blen) { return (a->len > blen) ? 1 : -1; } if (blen == 0) { return 0; } if (blen == 1) { if (a->limbs[0] == m0) { return 0; } return (a->limbs[0] > m0) ? 1 : -1; } if (a->limbs[1] != m1) { return (a->limbs[1] > m1) ? 1 : -1; } if (a->limbs[0] != m0) { return (a->limbs[0] > m0) ? 1 : -1; } return 0; } static int bigint_cmp_slo(const pl_bigint *a, SLO b) { const int as = a ? a->sign : 0; const int bs = (b > 0) ? 1 : (b < 0) ? -1 : 0; if (as != bs) { return (as > bs) ? 1 : -1; } if (as == 0) { return 0; } const int cmp = bigint_cmp_abs_slo(a, b); return (as > 0) ? cmp : -cmp; } static int bigint_cmp(const pl_bigint *a, const pl_bigint *b) { const int as = a ? a->sign : 0; const int bs = b ? b->sign : 0; if (as != bs) { return (as > bs) ? 1 : -1; } if (as == 0) { return 0; } const int cmp = bigint_cmp_abs(a, b); return (as > 0) ? cmp : -cmp; } static pl_bigint *bigint_add_abs(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { const ULO alen = a ? a->len : 0; const ULO blen = b ? b->len : 0; const ULO max = (alen > blen) ? alen : blen; pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, max + 1); uint64_t carry = 0; for (ULO i = 0; i < max; i++) { const uint64_t av = (i < alen) ? a->limbs[i] : 0; const uint64_t bv = (i < blen) ? b->limbs[i] : 0; const uint64_t sum = av + bv + carry; out->limbs[i] = (uint32_t)sum; carry = sum >> 32; } if (carry) { out->limbs[max] = (uint32_t)carry; out->len = max + 1; } else { out->len = max; } out->sign = out->len ? 1 : 0; return out; } static pl_bigint *bigint_sub_abs(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { const ULO alen = a ? a->len : 0; const ULO blen = b ? b->len : 0; pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, alen); int64_t borrow = 0; for (ULO i = 0; i < alen; i++) { const int64_t av = a->limbs[i]; const int64_t bv = (i < blen) ? b->limbs[i] : 0; int64_t diff = av - bv - borrow; if (diff < 0) { diff += (int64_t)BIGINT_BASE; borrow = 1; } else { borrow = 0; } out->limbs[i] = (uint32_t)diff; } out->len = alen; out->sign = 1; bigint_normalize(out); return out; } static pl_bigint *bigint_add_signed(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->sign == 0) { return bigint_copy(b, rt_ctrl, dbg_dat_ptr); } if (!b || b->sign == 0) { return bigint_copy(a, rt_ctrl, dbg_dat_ptr); } if (a->sign == b->sign) { pl_bigint *sum = bigint_add_abs(a, b, rt_ctrl, dbg_dat_ptr); sum->sign = a->sign; return sum; } const int cmp = bigint_cmp_abs(a, b); if (cmp == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (cmp > 0) { pl_bigint *diff = bigint_sub_abs(a, b, rt_ctrl, dbg_dat_ptr); diff->sign = a->sign; return diff; } pl_bigint *diff = bigint_sub_abs(b, a, rt_ctrl, dbg_dat_ptr); diff->sign = b->sign; return diff; } static pl_bigint *bigint_negate(const pl_bigint *a, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->sign == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, a->len); out->len = a->len; out->sign = -a->sign; memcpy(out->limbs, a->limbs, sizeof(uint32_t) * a->len); return out; } static pl_bigint *bigint_sub_signed(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!b || b->sign == 0) { return bigint_copy(a, rt_ctrl, dbg_dat_ptr); } pl_bigint *nb = bigint_negate(b, rt_ctrl, dbg_dat_ptr); pl_bigint *res = bigint_add_signed(a, nb, rt_ctrl, dbg_dat_ptr); return res; } #define BIGINT_KARATSUBA_THRESHOLD 64 #define BIGINT_KARATSUBA_BALANCE_FACTOR 2 static pl_bigint *bigint_mul_abs(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr); static pl_bigint *bigint_mul_abs_karatsuba(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr); static bool bigint_karatsuba_should_use(ULO alen, ULO blen); static pl_bigint *bigint_mul_abs_schoolbook(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || !b || a->len == 0 || b->len == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } const ULO alen = a->len; const ULO blen = b->len; pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, alen + blen); for (ULO i = 0; i < alen; i++) { unsigned __int128 carry = 0; for (ULO j = 0; j < blen; j++) { const ULO k = i + j; unsigned __int128 cur = (unsigned __int128)out->limbs[k]; cur += (unsigned __int128)a->limbs[i] * (unsigned __int128)b->limbs[j]; cur += carry; out->limbs[k] = (uint32_t)cur; carry = cur >> 32; } out->limbs[i + blen] = (uint32_t)carry; } out->len = alen + blen; out->sign = 1; bigint_normalize(out); return out; } static pl_bigint *bigint_sqr_abs(const pl_bigint *a, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->len == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } const ULO alen = a->len; if (bigint_karatsuba_should_use(alen, alen)) { return bigint_mul_abs_karatsuba(a, a, rt_ctrl, dbg_dat_ptr); } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, alen * 2); for (ULO i = 0; i < alen; i++) { unsigned __int128 carry = 0; ULO k = i + i; unsigned __int128 cur = (unsigned __int128)out->limbs[k]; cur += (unsigned __int128)a->limbs[i] * (unsigned __int128)a->limbs[i]; cur += carry; out->limbs[k] = (uint32_t)cur; carry = cur >> 32; k++; for (ULO j = i + 1; j < alen; j++, k++) { unsigned __int128 prod = (unsigned __int128)a->limbs[i] * (unsigned __int128)a->limbs[j]; unsigned __int128 cur2 = (unsigned __int128)out->limbs[k]; cur2 += (prod << 1); cur2 += carry; out->limbs[k] = (uint32_t)cur2; carry = cur2 >> 32; } while (carry && k < out->len) { unsigned __int128 cur3 = (unsigned __int128)out->limbs[k] + carry; out->limbs[k] = (uint32_t)cur3; carry = cur3 >> 32; k++; } } out->len = alen * 2; out->sign = 1; bigint_normalize(out); return out; } static bool bigint_karatsuba_should_use(ULO alen, ULO blen) { if (alen < BIGINT_KARATSUBA_THRESHOLD || blen < BIGINT_KARATSUBA_THRESHOLD) { return false; } const ULO max_len = (alen > blen) ? alen : blen; const ULO min_len = (alen > blen) ? blen : alen; return max_len <= min_len * BIGINT_KARATSUBA_BALANCE_FACTOR; } static pl_bigint *bigint_slice_abs(const pl_bigint *a, ULO start, ULO len, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->len <= start || len == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } ULO avail = a->len - start; if (len > avail) { len = avail; } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, len); if (len) { memcpy(out->limbs, a->limbs + start, sizeof(uint32_t) * len); out->len = len; out->sign = 1; bigint_normalize(out); } return out; } static void bigint_accum_limbs(uint32_t *dst, ULO dst_len, const uint32_t *src, ULO src_len, ULO offset) { if (!dst || !src || src_len == 0 || offset >= dst_len) { return; } if (offset + src_len > dst_len) { src_len = dst_len - offset; } uint64_t carry = 0; ULO k = offset; for (ULO i = 0; i < src_len; i++, k++) { uint64_t cur = (uint64_t)dst[k] + (uint64_t)src[i] + carry; dst[k] = (uint32_t)cur; carry = cur >> 32; } while (carry && k < dst_len) { uint64_t cur = (uint64_t)dst[k] + carry; dst[k] = (uint32_t)cur; carry = cur >> 32; k++; } } static pl_bigint *bigint_mul_abs_karatsuba(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { const ULO alen = a ? a->len : 0; const ULO blen = b ? b->len : 0; if (alen == 0 || blen == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } const ULO max_len = (alen > blen) ? alen : blen; const ULO m = max_len / 2; if (m == 0) { return bigint_mul_abs_schoolbook(a, b, rt_ctrl, dbg_dat_ptr); } pl_bigint *a0 = bigint_slice_abs(a, 0, m, rt_ctrl, dbg_dat_ptr); pl_bigint *a1 = bigint_slice_abs(a, m, alen > m ? (alen - m) : 0, rt_ctrl, dbg_dat_ptr); pl_bigint *b0 = bigint_slice_abs(b, 0, m, rt_ctrl, dbg_dat_ptr); pl_bigint *b1 = bigint_slice_abs(b, m, blen > m ? (blen - m) : 0, rt_ctrl, dbg_dat_ptr); pl_bigint *z0 = bigint_mul_abs(a0, b0, rt_ctrl, dbg_dat_ptr); pl_bigint *z2 = bigint_mul_abs(a1, b1, rt_ctrl, dbg_dat_ptr); pl_bigint *a01 = bigint_add_abs(a0, a1, rt_ctrl, dbg_dat_ptr); pl_bigint *b01 = bigint_add_abs(b0, b1, rt_ctrl, dbg_dat_ptr); pl_bigint *z1 = bigint_mul_abs(a01, b01, rt_ctrl, dbg_dat_ptr); z1 = bigint_sub_abs(z1, z0, rt_ctrl, dbg_dat_ptr); z1 = bigint_sub_abs(z1, z2, rt_ctrl, dbg_dat_ptr); pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, alen + blen); bigint_accum_limbs(out->limbs, out->len, z0->limbs, z0->len, 0); bigint_accum_limbs(out->limbs, out->len, z1->limbs, z1->len, m); bigint_accum_limbs(out->limbs, out->len, z2->limbs, z2->len, m * 2); out->len = alen + blen; out->sign = 1; bigint_normalize(out); return out; } static pl_bigint *bigint_mul_abs(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || !b || a->len == 0 || b->len == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (a == b) { return bigint_sqr_abs(a, rt_ctrl, dbg_dat_ptr); } if (bigint_karatsuba_should_use(a->len, b->len)) { return bigint_mul_abs_karatsuba(a, b, rt_ctrl, dbg_dat_ptr); } return bigint_mul_abs_schoolbook(a, b, rt_ctrl, dbg_dat_ptr); } static pl_bigint *bigint_mul_signed(const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || !b || a->sign == 0 || b->sign == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } pl_bigint *out = bigint_mul_abs(a, b, rt_ctrl, dbg_dat_ptr); out->sign = (a->sign == b->sign) ? 1 : -1; return out; } static pl_bigint *bigint_add_small_abs(const pl_bigint *a, uint32_t add, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->len == 0) { pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, add ? 1 : 0); if (add) { out->limbs[0] = add; out->len = 1; out->sign = 1; } return out; } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, a->len + 1); uint64_t carry = add; for (ULO i = 0; i < a->len; i++) { uint64_t cur = (uint64_t)a->limbs[i] + carry; out->limbs[i] = (uint32_t)cur; carry = cur >> 32; } if (carry) { out->limbs[a->len] = (uint32_t)carry; out->len = a->len + 1; } else { out->len = a->len; } out->sign = 1; return out; } static uint32_t bigint_div_mod_small_inplace(uint32_t *limbs, ULO *len, uint32_t div) { if (!limbs || !len || !*len || !div) { return 0; } uint64_t rem = 0; for (ULO i = *len; i > 0; i--) { const uint64_t cur = (rem << 32) | limbs[i - 1]; limbs[i - 1] = (uint32_t)(cur / div); rem = cur % div; } while (*len > 0 && limbs[*len - 1] == 0) { (*len)--; } return (uint32_t)rem; } static pl_bigint *bigint_div_mod_abs(const pl_bigint *a, const pl_bigint *b, pl_bigint **out_rem, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out_rem) { return NULL; } *out_rem = NULL; if (!a || a->len == 0) { *out_rem = bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (!b || b->len == 0) { return NULL; } if (bigint_cmp_abs(a, b) < 0) { pl_bigint *q = bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); pl_bigint *r = bigint_alloc(rt_ctrl, dbg_dat_ptr, a->len); r->len = a->len; r->sign = 1; memcpy(r->limbs, a->limbs, sizeof(uint32_t) * a->len); *out_rem = r; return q; } if (b->len == 1) { const uint32_t div = b->limbs[0]; pl_bigint *q = bigint_alloc(rt_ctrl, dbg_dat_ptr, a->len); q->len = a->len; q->sign = 1; memcpy(q->limbs, a->limbs, sizeof(uint32_t) * a->len); uint32_t rem = bigint_div_mod_small_inplace(q->limbs, &q->len, div); bigint_normalize(q); pl_bigint *r = rem ? bigint_alloc(rt_ctrl, dbg_dat_ptr, 1) : bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); if (rem) { r->limbs[0] = rem; r->len = 1; r->sign = 1; } *out_rem = r; return q; } const ULO n = b->len; const ULO m = a->len - n; const uint32_t vmsw = b->limbs[n - 1]; const uint32_t d = (uint32_t)(BIGINT_BASE / ((uint64_t)vmsw + 1)); pl_bigint_scratch *scratch = &g_bigint_scratch; const ULO un_len = a->len + 1; const ULO vn_len = b->len; uint32_t *un = bigint_scratch_reserve(&scratch->buf1, &scratch->cap1, un_len); uint32_t *vn = bigint_scratch_reserve(&scratch->buf2, &scratch->cap2, vn_len); if (!un || !vn) { return NULL; } memset(un, 0, sizeof(uint32_t) * un_len); memset(vn, 0, sizeof(uint32_t) * vn_len); // Normalize (multiply by d). uint64_t carry = 0; for (ULO i = 0; i < a->len; i++) { uint64_t cur = (uint64_t)a->limbs[i] * d + carry; un[i] = (uint32_t)cur; carry = cur >> 32; } un[a->len] = (uint32_t)carry; carry = 0; for (ULO i = 0; i < b->len; i++) { uint64_t cur = (uint64_t)b->limbs[i] * d + carry; vn[i] = (uint32_t)cur; carry = cur >> 32; } pl_bigint *q = bigint_alloc(rt_ctrl, dbg_dat_ptr, m + 1); for (ULO j = m + 1; j > 0; j--) { q->limbs[j - 1] = 0; } for (ULO j = m + 1; j-- > 0;) { const ULO jn = j + n; unsigned __int128 ujn = ((unsigned __int128)un[jn] << 32) | un[jn - 1]; uint64_t qhat = (uint64_t)(ujn / vn[n - 1]); uint64_t rhat = (uint64_t)(ujn % vn[n - 1]); if (qhat >= BIGINT_BASE) { qhat = BIGINT_BASE - 1; rhat = (uint64_t)(ujn - qhat * vn[n - 1]); } if (n > 1) { while (qhat * vn[n - 2] > (rhat << 32) + un[jn - 2]) { qhat--; rhat += vn[n - 1]; if (rhat >= BIGINT_BASE) { break; } } } int64_t borrow = 0; unsigned __int128 carry_mul = 0; for (ULO i = 0; i < n; i++) { unsigned __int128 p = (unsigned __int128)qhat * vn[i] + carry_mul; carry_mul = p >> 32; int64_t diff = (int64_t)un[j + i] - (int64_t)(uint32_t)p - borrow; if (diff < 0) { diff += (int64_t)BIGINT_BASE; borrow = 1; } else { borrow = 0; } un[j + i] = (uint32_t)diff; } int64_t diff = (int64_t)un[j + n] - (int64_t)carry_mul - borrow; if (diff < 0) { qhat--; uint64_t carry_add = 0; for (ULO i = 0; i < n; i++) { uint64_t cur = (uint64_t)un[j + i] + vn[i] + carry_add; un[j + i] = (uint32_t)cur; carry_add = cur >> 32; } un[j + n] += (uint32_t)carry_add; } else { un[j + n] = (uint32_t)diff; } q->limbs[j] = (uint32_t)qhat; } q->len = m + 1; q->sign = 1; bigint_normalize(q); pl_bigint *r = bigint_alloc(rt_ctrl, dbg_dat_ptr, n); r->len = n; r->sign = 1; memcpy(r->limbs, un, sizeof(uint32_t) * n); ULO rlen = r->len; (void)bigint_div_mod_small_inplace(r->limbs, &rlen, d); r->len = rlen; bigint_normalize(r); *out_rem = r; return q; } static pl_bigint *bigint_div_mod_signed(const pl_bigint *a, const pl_bigint *b, bool floor_div, pl_bigint **out_rem, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out_rem) { return NULL; } *out_rem = NULL; if (!a || a->sign == 0) { *out_rem = bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (!b || b->sign == 0) { return NULL; } pl_bigint *rem_abs = NULL; pl_bigint *q_abs = bigint_div_mod_abs(a, b, &rem_abs, rt_ctrl, dbg_dat_ptr); if (!q_abs || !rem_abs) { return NULL; } const bool diff_sign = (a->sign != b->sign); if (floor_div && diff_sign && !bigint_is_zero(rem_abs)) { pl_bigint *q_plus = bigint_add_small_abs(q_abs, 1, rt_ctrl, dbg_dat_ptr); q_plus->sign = -1; pl_bigint *rem_adj = bigint_sub_abs(b, rem_abs, rt_ctrl, dbg_dat_ptr); rem_adj->sign = b->sign; *out_rem = rem_adj; return q_plus; } q_abs->sign = diff_sign ? -1 : 1; if (bigint_is_zero(q_abs)) { q_abs->sign = 0; } rem_abs->sign = a->sign; if (bigint_is_zero(rem_abs)) { rem_abs->sign = 0; } *out_rem = rem_abs; return q_abs; } static pl_bigint *bigint_shift_left_abs(const pl_bigint *a, ULO shift, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->len == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (shift == 0) { return bigint_copy(a, rt_ctrl, dbg_dat_ptr); } const ULO limb_shift = shift / BIGINT_BASE_BITS; const ULO bit_shift = shift % BIGINT_BASE_BITS; const ULO out_len = a->len + limb_shift + (bit_shift ? 1 : 0); pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, out_len); uint32_t carry = 0; for (ULO i = 0; i < a->len; i++) { uint64_t cur = ((uint64_t)a->limbs[i] << bit_shift) | carry; out->limbs[i + limb_shift] = (uint32_t)cur; carry = (uint32_t)(cur >> 32); } if (bit_shift) { out->limbs[a->len + limb_shift] = carry; } out->len = out_len; out->sign = a->sign; bigint_normalize(out); return out; } static bool bigint_has_shift_remainder(const pl_bigint *a, ULO shift) { if (!a || a->len == 0 || shift == 0) { return false; } const ULO limb_shift = shift / BIGINT_BASE_BITS; const ULO bit_shift = shift % BIGINT_BASE_BITS; for (ULO i = 0; i < limb_shift && i < a->len; i++) { if (a->limbs[i] != 0) { return true; } } if (bit_shift && limb_shift < a->len) { const uint32_t mask = (1u << bit_shift) - 1u; if (a->limbs[limb_shift] & mask) { return true; } } return false; } static pl_bigint *bigint_shift_right_abs(const pl_bigint *a, ULO shift, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->len == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (shift == 0) { pl_bigint *out = bigint_copy(a, rt_ctrl, dbg_dat_ptr); out->sign = out->len ? 1 : 0; return out; } const ULO limb_shift = shift / BIGINT_BASE_BITS; const ULO bit_shift = shift % BIGINT_BASE_BITS; if (limb_shift >= a->len) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } const ULO out_len = a->len - limb_shift; pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, out_len); if (bit_shift == 0) { memcpy(out->limbs, a->limbs + limb_shift, sizeof(uint32_t) * out_len); } else { for (ULO i = 0; i < out_len; i++) { const uint32_t low = a->limbs[i + limb_shift]; const uint32_t high = ((i + limb_shift + 1) < a->len) ? a->limbs[i + limb_shift + 1] : 0; out->limbs[i] = (low >> bit_shift) | (high << (32 - bit_shift)); } } out->len = out_len; out->sign = 1; bigint_normalize(out); return out; } static pl_bigint *bigint_shift_right_floor(const pl_bigint *a, ULO shift, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!a || a->sign == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (shift == 0) { return bigint_copy(a, rt_ctrl, dbg_dat_ptr); } if (a->sign > 0) { pl_bigint *out = bigint_shift_right_abs(a, shift, rt_ctrl, dbg_dat_ptr); out->sign = out->len ? 1 : 0; return out; } pl_bigint *out = bigint_shift_right_abs(a, shift, rt_ctrl, dbg_dat_ptr); if (bigint_has_shift_remainder(a, shift)) { pl_bigint *adj = bigint_add_small_abs(out, 1, rt_ctrl, dbg_dat_ptr); adj->sign = adj->len ? -1 : 0; return adj; } out->sign = out->len ? -1 : 0; return out; } static bool bigint_to_twos_buf(const pl_bigint *a, ULO bits, uint32_t *out, ULO len) { if (!out || !bits || !len) { return false; } memset(out, 0, sizeof(uint32_t) * len); if (!a || a->len == 0 || a->sign == 0) { return true; } const ULO copy = (a->len < len) ? a->len : len; memcpy(out, a->limbs, sizeof(uint32_t) * copy); if (a->sign < 0) { for (ULO i = 0; i < len; i++) { out[i] = ~out[i]; } uint64_t carry = 1; for (ULO i = 0; i < len; i++) { uint64_t cur = (uint64_t)out[i] + carry; out[i] = (uint32_t)cur; carry = cur >> 32; if (!carry) { break; } } } if (bits % 32) { const uint32_t mask = (1u << (bits % 32)) - 1u; out[len - 1] &= mask; } return true; } static pl_bigint *bigint_from_twos_buf(uint32_t *in, ULO bits, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!in || !bits) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } const ULO len = (bits + 31) / 32; if (bits % 32) { const uint32_t mask = (1u << (bits % 32)) - 1u; in[len - 1] &= mask; } const ULO sign_bit = bits - 1; const ULO sign_limb = sign_bit / 32; const ULO sign_off = sign_bit % 32; const bool negative = (in[sign_limb] >> sign_off) & 1u; if (!negative) { pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, len); out->len = len; out->sign = 1; memcpy(out->limbs, in, sizeof(uint32_t) * len); bigint_normalize(out); return out; } for (ULO i = 0; i < len; i++) { in[i] = ~in[i]; } uint64_t carry = 1; for (ULO i = 0; i < len; i++) { uint64_t cur = (uint64_t)in[i] + carry; in[i] = (uint32_t)cur; carry = cur >> 32; if (!carry) { break; } } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, len); out->len = len; out->sign = -1; memcpy(out->limbs, in, sizeof(uint32_t) * len); bigint_normalize(out); return out; } typedef enum { BIGINT_BOP_AND = 0, BIGINT_BOP_OR = 1, BIGINT_BOP_XOR = 2, } bigint_bop_kind; static pl_bigint *bigint_bitwise_op(const pl_bigint *a, const pl_bigint *b, bigint_bop_kind op, const void *rt_ctrl, const ULO *dbg_dat_ptr) { const int as = a ? a->sign : 0; const int bs = b ? b->sign : 0; const ULO alen = a ? a->len : 0; const ULO blen = b ? b->len : 0; if (as >= 0 && bs >= 0) { const ULO out_len = (alen > blen) ? alen : blen; if (out_len == 0) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, out_len); for (ULO i = 0; i < out_len; i++) { const uint32_t av = (i < alen) ? a->limbs[i] : 0; const uint32_t bv = (i < blen) ? b->limbs[i] : 0; if (op == BIGINT_BOP_AND) { out->limbs[i] = av & bv; } else if (op == BIGINT_BOP_OR) { out->limbs[i] = av | bv; } else { out->limbs[i] = av ^ bv; } } out->len = out_len; out->sign = 1; bigint_normalize(out); return out; } ULO bits = bigint_bit_length_abs(a); const ULO bb = bigint_bit_length_abs(b); if (bb > bits) { bits = bb; } bits = bits ? (bits + 1) : 1; const ULO len = (bits + 31) / 32; pl_bigint_scratch *scratch = &g_bigint_scratch; uint32_t *ta = bigint_scratch_reserve(&scratch->buf1, &scratch->cap1, len); uint32_t *tb = bigint_scratch_reserve(&scratch->buf2, &scratch->cap2, len); if (!ta || !tb) { return NULL; } if (!bigint_to_twos_buf(a, bits, ta, len) || !bigint_to_twos_buf(b, bits, tb, len)) { return NULL; } for (ULO i = 0; i < len; i++) { switch (op) { case BIGINT_BOP_AND: ta[i] &= tb[i]; break; case BIGINT_BOP_OR: ta[i] |= tb[i]; break; case BIGINT_BOP_XOR: ta[i] ^= tb[i]; break; default: break; } } return bigint_from_twos_buf(ta, bits, rt_ctrl, dbg_dat_ptr); } static pl_bigint *bigint_bnot(const pl_bigint *a, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_bigint *one = bigint_from_slo(rt_ctrl, dbg_dat_ptr, 1); pl_bigint *sum = bigint_add_signed(a, one, rt_ctrl, dbg_dat_ptr); pl_bigint *out = bigint_negate(sum, rt_ctrl, dbg_dat_ptr); return out; } static pl_bigint *bigint_pow_u64(const pl_bigint *base, uint64_t exp, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!base || base->sign == 0) { return exp == 0 ? bigint_from_slo(rt_ctrl, dbg_dat_ptr, 1) : bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } if (exp == 0) { return bigint_from_slo(rt_ctrl, dbg_dat_ptr, 1); } const int sign = (base->sign < 0 && (exp & 1u)) ? -1 : 1; pl_bigint *result = bigint_from_slo(rt_ctrl, dbg_dat_ptr, 1); pl_bigint *pow = bigint_copy(base, rt_ctrl, dbg_dat_ptr); pow->sign = 1; uint64_t e = exp; while (e) { if (e & 1u) { result = bigint_mul_abs(result, pow, rt_ctrl, dbg_dat_ptr); } e >>= 1; if (e) { pow = bigint_sqr_abs(pow, rt_ctrl, dbg_dat_ptr); } } result->sign = result->len ? sign : 0; return result; } static int bigint_digit_val(unsigned char c) { if (c >= '0' && c <= '9') { return (int)(c - '0'); } if (c >= 'a' && c <= 'z') { return 10 + (int)(c - 'a'); } if (c >= 'A' && c <= 'Z') { return 10 + (int)(c - 'A'); } return -1; } static pl_bigint *bigint_from_cstr_base(const CHR *s, size_t len, int base, int sign, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!s || !len || base < 2 || base > 36) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } size_t i = 0; while (i < len && s[i] == '0') { i++; } if (i == len) { return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } ULO cap = 0; ULO used = 0; uint32_t *limbs = NULL; for (; i < len; i++) { const int dv = bigint_digit_val((unsigned char)s[i]); if (dv < 0 || dv >= base) { free(limbs); return NULL; } uint64_t carry = (uint32_t)dv; for (ULO j = 0; j < used; j++) { uint64_t cur = (uint64_t)limbs[j] * (uint64_t)base + carry; limbs[j] = (uint32_t)cur; carry = cur >> 32; } if (carry) { if (used == cap) { ULO new_cap = cap ? cap * 2 : 4; uint32_t *new_limbs = (uint32_t *)realloc(limbs, sizeof(uint32_t) * new_cap); if (!new_limbs) { free(limbs); return NULL; } limbs = new_limbs; cap = new_cap; } limbs[used++] = (uint32_t)carry; } else if (!used) { if (used == cap) { ULO new_cap = cap ? cap * 2 : 4; uint32_t *new_limbs = (uint32_t *)realloc(limbs, sizeof(uint32_t) * new_cap); if (!new_limbs) { free(limbs); return NULL; } limbs = new_limbs; cap = new_cap; } limbs[used++] = 0; } } if (!used) { free(limbs); return bigint_alloc(rt_ctrl, dbg_dat_ptr, 0); } pl_bigint *out = bigint_alloc(rt_ctrl, dbg_dat_ptr, used); out->len = used; out->sign = sign; memcpy(out->limbs, limbs, sizeof(uint32_t) * used); bigint_normalize(out); free(limbs); return out; } static bool bigint_fits_slo(const pl_bigint *b, SLO *out) { if (!b || b->len == 0 || b->sign == 0) { if (out) { *out = 0; } return true; } const ULO bits = bigint_bit_length_abs(b); const ULO max_bits = (ULO)(sizeof(SLO) * 8); if (b->sign > 0) { if (bits >= max_bits) { return false; } } else { if (bits > max_bits) { return false; } if (bits == max_bits) { // Only fits if magnitude == 2^(max_bits-1). if (b->len < (max_bits + 31) / 32) { // ok } else { ULO shift = max_bits - 1; ULO limb = shift / 32; ULO bit = shift % 32; for (ULO i = 0; i < b->len; i++) { uint32_t v = b->limbs[i]; if (i == limb) { if (v != (1u << bit)) { return false; } } else if (v != 0) { return false; } } } } } unsigned __int128 mag = 0; for (ULO i = b->len; i > 0; i--) { mag = (mag << 32) | b->limbs[i - 1]; } if (b->sign < 0) { const unsigned __int128 min_mag = (unsigned __int128)1u << (max_bits - 1); if (mag == min_mag) { *out = LONG_MIN; } else { *out = (SLO)(-(SLO)mag); } } else { *out = (SLO)mag; } return true; } static bool bigint_to_ulo(const pl_bigint *b, ULO *out) { if (out) { *out = 0; } if (!b || b->len == 0 || b->sign == 0) { return true; } if (b->sign < 0) { return false; } const ULO bits = bigint_bit_length_abs(b); if (bits > (ULO)(sizeof(ULO) * 8)) { return false; } ULO v = 0; for (ULO i = b->len; i > 0; i--) { v = (v << 32) | b->limbs[i - 1]; } if (out) { *out = v; } return true; } static bool bigint_to_double(const pl_bigint *b, double *out) { if (!out) { return false; } if (!b || b->len == 0 || b->sign == 0) { *out = 0.0; return true; } double acc = 0.0; for (ULO i = b->len; i > 0; i--) { acc = acc * (double)BIGINT_BASE + (double)b->limbs[i - 1]; if (!isfinite(acc)) { *out = b->sign < 0 ? -HUGE_VAL : HUGE_VAL; return false; } } *out = (b->sign < 0) ? -acc : acc; return isfinite(*out); } static char *bigint_to_cstr(const pl_bigint *b) { if (!b || b->len == 0 || b->sign == 0) { char *s = (char *)malloc(2); if (s) { s[0] = '0'; s[1] = '\0'; } return s; } uint32_t *tmp = (uint32_t *)malloc(sizeof(uint32_t) * b->len); if (!tmp) { return NULL; } memcpy(tmp, b->limbs, sizeof(uint32_t) * b->len); ULO tlen = b->len; ULO chunk_cap = 0; ULO chunk_len = 0; uint32_t *chunks = NULL; const uint32_t div = 1000000000u; while (tlen > 0) { const uint32_t rem = bigint_div_mod_small_inplace(tmp, &tlen, div); if (chunk_len == chunk_cap) { ULO new_cap = chunk_cap ? chunk_cap * 2 : 8; uint32_t *new_chunks = (uint32_t *)realloc(chunks, sizeof(uint32_t) * new_cap); if (!new_chunks) { free(chunks); free(tmp); return NULL; } chunks = new_chunks; chunk_cap = new_cap; } chunks[chunk_len++] = rem; } free(tmp); if (chunk_len == 0) { free(chunks); char *s = (char *)malloc(2); if (s) { s[0] = '0'; s[1] = '\0'; } return s; } char first_buf[32]; (void)snprintf(first_buf, sizeof(first_buf), "%u", chunks[chunk_len - 1]); const size_t first_len = strlen(first_buf); const size_t total_len = first_len + (chunk_len - 1) * 9 + (b->sign < 0 ? 1 : 0); char *out = (char *)malloc(total_len + 1); if (!out) { free(chunks); return NULL; } size_t off = 0; if (b->sign < 0) { out[off++] = '-'; } memcpy(out + off, first_buf, first_len); off += first_len; for (ULO i = chunk_len - 1; i-- > 0;) { char buf[16]; (void)snprintf(buf, sizeof(buf), "%09u", chunks[i]); memcpy(out + off, buf, 9); off += 9; } out[off] = '\0'; free(chunks); return out; } typedef enum { PL_NUM_INT = 0, PL_NUM_BIGINT = 1, PL_NUM_FLOAT = 2, } pl_num_kind; typedef struct { pl_num_kind kind; SLO ival; double fval; pl_bigint *big; } pl_number; static pl_number num_from_int(SLO v) { return (pl_number){.kind = PL_NUM_INT, .ival = v, .fval = (double)v}; } static pl_number num_from_big(pl_bigint *b) { return (pl_number){.kind = PL_NUM_BIGINT, .big = b}; } static pl_number num_from_float(double v) { return (pl_number){.kind = PL_NUM_FLOAT, .fval = v}; } static double num_as_double(pl_number n) { if (n.kind == PL_NUM_FLOAT) { return n.fval; } if (n.kind == PL_NUM_INT) { return (double)n.ival; } if (!n.big) { return 0.0; } double v = 0.0; if (!bigint_to_double(n.big, &v)) { return n.big->sign < 0 ? -HUGE_VAL : HUGE_VAL; } return v; } static inline bool num_is_float(pl_number n) { return n.kind == PL_NUM_FLOAT; } static inline bool num_is_big(pl_number n) { return n.kind == PL_NUM_BIGINT; } static inline bool num_is_int(pl_number n) { return n.kind == PL_NUM_INT; } static inline bool num_is_integer(pl_number n) { return n.kind == PL_NUM_INT || n.kind == PL_NUM_BIGINT; } static pl_bigint *num_to_bigint(pl_number n, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (n.kind == PL_NUM_BIGINT) { return n.big; } if (n.kind == PL_NUM_INT) { return bigint_from_slo(rt_ctrl, dbg_dat_ptr, n.ival); } return NULL; } static int num_cmp(pl_number a, pl_number b) { if (num_is_float(a) || num_is_float(b)) { const double da = num_as_double(a); const double db = num_as_double(b); if (da < db) { return -1; } if (da > db) { return 1; } return 0; } if (num_is_int(a) && num_is_int(b)) { if (a.ival < b.ival) { return -1; } if (a.ival > b.ival) { return 1; } return 0; } if (num_is_big(a) && num_is_big(b)) { return bigint_cmp(a.big, b.big); } if (num_is_big(a)) { return bigint_cmp_slo(a.big, b.ival); } return -bigint_cmp_slo(b.big, a.ival); } static pl_number num_from_big_canon(pl_bigint *b) { if (!b) { return num_from_int(0); } SLO v = 0; if (bigint_fits_slo(b, &v)) { return num_from_int(v); } return num_from_big(b); } static bool int_floor_div_mod(SLO a, SLO b, SLO *q_out, SLO *r_out); static bool add_overflow_slo(SLO a, SLO b, SLO *out); static bool sub_overflow_slo(SLO a, SLO b, SLO *out); static bool mul_overflow_slo(SLO a, SLO b, SLO *out); static bool int_pow_checked(SLO base, SLO exp, SLO *out); typedef enum { NUM_BIN_ADD = 0, NUM_BIN_SUB = 1, NUM_BIN_MUL = 2, } num_binop_kind; static pl_bigint *bigint_binop_signed(num_binop_kind op, const pl_bigint *a, const pl_bigint *b, const void *rt_ctrl, const ULO *dbg_dat_ptr) { switch (op) { case NUM_BIN_ADD: return bigint_add_signed(a, b, rt_ctrl, dbg_dat_ptr); case NUM_BIN_SUB: return bigint_sub_signed(a, b, rt_ctrl, dbg_dat_ptr); case NUM_BIN_MUL: return bigint_mul_signed(a, b, rt_ctrl, dbg_dat_ptr); default: return NULL; } } static bool num_binop_int(pl_number a, pl_number b, pl_number *out, num_binop_kind op, bool (*overflow)(SLO, SLO, SLO *), const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out || !overflow) { return false; } if (num_is_big(a) || num_is_big(b)) { pl_bigint *ba = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); pl_bigint *bb = num_to_bigint(b, rt_ctrl, dbg_dat_ptr); if (!ba || !bb) { return false; } pl_bigint *res = bigint_binop_signed(op, ba, bb, rt_ctrl, dbg_dat_ptr); if (!res) { return false; } *out = num_from_big_canon(res); return true; } SLO tmp = 0; if (!overflow(a.ival, b.ival, &tmp)) { *out = num_from_int(tmp); return true; } pl_bigint *ba = bigint_from_slo(rt_ctrl, dbg_dat_ptr, a.ival); pl_bigint *bb = bigint_from_slo(rt_ctrl, dbg_dat_ptr, b.ival); pl_bigint *res = bigint_binop_signed(op, ba, bb, rt_ctrl, dbg_dat_ptr); if (!res) { return false; } *out = num_from_big_canon(res); return true; } static bool num_add_int(pl_number a, pl_number b, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { return num_binop_int(a, b, out, NUM_BIN_ADD, add_overflow_slo, rt_ctrl, dbg_dat_ptr); } static bool num_sub_int(pl_number a, pl_number b, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { return num_binop_int(a, b, out, NUM_BIN_SUB, sub_overflow_slo, rt_ctrl, dbg_dat_ptr); } static bool num_mul_int(pl_number a, pl_number b, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { return num_binop_int(a, b, out, NUM_BIN_MUL, mul_overflow_slo, rt_ctrl, dbg_dat_ptr); } static bool num_neg_int(pl_number a, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out) { return false; } if (num_is_big(a)) { pl_bigint *neg = bigint_negate(a.big, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(neg); return true; } if (a.ival == LONG_MIN) { pl_bigint *ba = bigint_from_slo(rt_ctrl, dbg_dat_ptr, a.ival); pl_bigint *neg = bigint_negate(ba, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(neg); return true; } *out = num_from_int(-a.ival); return true; } static bool num_abs_int(pl_number a, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out) { return false; } if (num_is_big(a)) { if (!a.big || a.big->sign >= 0) { *out = a; return true; } pl_bigint *neg = bigint_negate(a.big, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(neg); return true; } if (a.ival >= 0) { *out = a; return true; } if (a.ival == LONG_MIN) { pl_bigint *ba = bigint_from_slo(rt_ctrl, dbg_dat_ptr, a.ival); pl_bigint *neg = bigint_negate(ba, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(neg); return true; } *out = num_from_int(-a.ival); return true; } static bool num_bnot_int(pl_number a, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out) { return false; } if (num_is_big(a)) { pl_bigint *res = bigint_bnot(a.big, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(res); return true; } *out = num_from_int(~a.ival); return true; } static bool num_bitwise_op(pl_number a, pl_number b, bigint_bop_kind op, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out) { return false; } if (num_is_big(a) || num_is_big(b)) { pl_bigint *ba = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); pl_bigint *bb = num_to_bigint(b, rt_ctrl, dbg_dat_ptr); if (!ba || !bb) { return false; } pl_bigint *res = bigint_bitwise_op(ba, bb, op, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(res); return true; } SLO ai = a.ival; SLO bi = b.ival; if (op == BIGINT_BOP_AND) { *out = num_from_int(ai & bi); } else if (op == BIGINT_BOP_OR) { *out = num_from_int(ai | bi); } else { *out = num_from_int(ai ^ bi); } return true; } static bool num_shift_left(pl_number a, ULO shift, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out) { return false; } if (shift == 0) { *out = a; return true; } if (num_is_int(a)) { if (shift <= (ULO)LONG_MAX) { SLO pow2 = 0; if (int_pow_checked(2, (SLO)shift, &pow2)) { SLO tmp = 0; if (!mul_overflow_slo(a.ival, pow2, &tmp)) { *out = num_from_int(tmp); return true; } } } } pl_bigint *ba = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); if (!ba) { return false; } pl_bigint *res = bigint_shift_left_abs(ba, shift, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(res); return true; } static bool num_shift_right(pl_number a, ULO shift, pl_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out) { return false; } if (shift == 0) { *out = a; return true; } if (num_is_int(a)) { if (shift <= (ULO)LONG_MAX) { SLO pow2 = 0; if (int_pow_checked(2, (SLO)shift, &pow2) && (pow2 > 0)) { SLO q = 0; if (int_floor_div_mod(a.ival, pow2, &q, NULL)) { *out = num_from_int(q); return true; } } else { if (a.ival == 0) { *out = num_from_int(0); } else { *out = num_from_int(a.ival < 0 ? -1 : 0); } return true; } } else { if (a.ival == 0) { *out = num_from_int(0); } else { *out = num_from_int(a.ival < 0 ? -1 : 0); } return true; } } pl_bigint *ba = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); if (!ba) { return false; } pl_bigint *res = bigint_shift_right_floor(ba, shift, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(res); return true; } typedef enum { NUM_DIV_OK = 0, NUM_DIV_ZERO, NUM_DIV_UNDEFINED, } num_div_status; static num_div_status num_div_mod_int(pl_number a, pl_number b, bool floor_div, pl_number *q_out, pl_number *r_out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!num_is_integer(a) || !num_is_integer(b)) { return NUM_DIV_UNDEFINED; } if (num_is_int(b) && (b.ival == 0)) { return NUM_DIV_ZERO; } if (num_is_big(b) && bigint_is_zero(b.big)) { return NUM_DIV_ZERO; } const bool overflow_case = num_is_int(a) && num_is_int(b) && (a.ival == LONG_MIN) && (b.ival == -1); if (num_is_int(a) && num_is_int(b) && !overflow_case) { if (floor_div) { SLO q = 0, r = 0; if (!int_floor_div_mod(a.ival, b.ival, q_out ? &q : NULL, r_out ? &r : NULL)) { return NUM_DIV_ZERO; } if (q_out) { *q_out = num_from_int(q); } if (r_out) { *r_out = num_from_int(r); } } else { const SLO q = a.ival / b.ival; const SLO r = a.ival % b.ival; if (q_out) { *q_out = num_from_int(q); } if (r_out) { *r_out = num_from_int(r); } } return NUM_DIV_OK; } pl_bigint *ba = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); pl_bigint *bb = num_to_bigint(b, rt_ctrl, dbg_dat_ptr); if (!ba || !bb) { return NUM_DIV_UNDEFINED; } if (bigint_is_zero(bb)) { return NUM_DIV_ZERO; } pl_bigint *rem = NULL; pl_bigint *q = bigint_div_mod_signed(ba, bb, floor_div, &rem, rt_ctrl, dbg_dat_ptr); if (!q || !rem) { return NUM_DIV_UNDEFINED; } if (q_out) { *q_out = num_from_big_canon(q); } if (r_out) { *r_out = num_from_big_canon(rem); } return NUM_DIV_OK; } static pl_term *num_to_term_rt(pl_number n, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (num_is_float(n)) { return make_float_rt(rt_ctrl, dbg_dat_ptr, n.fval); } if (num_is_big(n)) { return make_bigint_rt(rt_ctrl, dbg_dat_ptr, n.big); } return make_int_rt(rt_ctrl, dbg_dat_ptr, n.ival); } static bool int_floor_div_mod(SLO a, SLO b, SLO *q_out, SLO *r_out) { if (b == 0) { return false; } SLO q = a / b; // trunc toward 0 SLO r = a % b; if (r && ((r > 0) != (b > 0))) { q -= 1; r += b; } if (q_out) { *q_out = q; } if (r_out) { *r_out = r; } return true; } static bool double_to_slo_checked(double v, SLO *out) { if (!out || !isfinite(v)) { return false; } if (v < (double)LONG_MIN || v > (double)LONG_MAX) { return false; } *out = (SLO)v; return true; } static bool add_overflow_slo(SLO a, SLO b, SLO *out) { #if defined(__has_builtin) # if __has_builtin(__builtin_add_overflow) return __builtin_add_overflow(a, b, out); # endif #endif __int128 tmp = (__int128)a + (__int128)b; if (tmp < (SLO)LONG_MIN || tmp > (SLO)LONG_MAX) { return true; } *out = (SLO)tmp; return false; } static bool sub_overflow_slo(SLO a, SLO b, SLO *out) { #if defined(__has_builtin) # if __has_builtin(__builtin_sub_overflow) return __builtin_sub_overflow(a, b, out); # endif #endif __int128 tmp = (__int128)a - (__int128)b; if (tmp < (SLO)LONG_MIN || tmp > (SLO)LONG_MAX) { return true; } *out = (SLO)tmp; return false; } static bool mul_overflow_slo(SLO a, SLO b, SLO *out) { #if defined(__has_builtin) # if __has_builtin(__builtin_mul_overflow) return __builtin_mul_overflow(a, b, out); # endif #endif __int128 tmp = (__int128)a * (__int128)b; if (tmp < (SLO)LONG_MIN || tmp > (SLO)LONG_MAX) { return true; } *out = (SLO)tmp; return false; } static bool int_pow_checked(SLO base, SLO exp, SLO *out) { if (!out || (exp < 0)) { return false; } SLO result = 1; SLO pow = base; SLO e = exp; while (e) { if (e & 1) { SLO tmp = 0; if (mul_overflow_slo(result, pow, &tmp)) { return false; } result = tmp; } e >>= 1; if (!e) { break; } SLO tmp = 0; if (mul_overflow_slo(pow, pow, &tmp)) { return false; } pow = tmp; } *out = result; return true; } typedef enum { PL_ARITH_ERR_NONE = 0, PL_ARITH_ERR_INSTANTIATION, PL_ARITH_ERR_TYPE_EVALUABLE, PL_ARITH_ERR_TYPE_INTEGER, PL_ARITH_ERR_TYPE_FLOAT, PL_ARITH_ERR_EVAL_ZERO_DIVISOR, PL_ARITH_ERR_EVAL_UNDEFINED, } pl_arith_err_kind; typedef struct { pl_arith_err_kind kind; const pl_term *culprit; const CHR *evaluable_name; ULO evaluable_arity; } pl_arith_error; static void arith_err_set(pl_arith_error *err, pl_arith_err_kind kind) { if (!err) { return; } err->kind = kind; } static void arith_err_set_culprit(pl_arith_error *err, pl_arith_err_kind kind, const pl_term *culprit) { if (!err) { return; } err->kind = kind; err->culprit = culprit; } static void arith_err_set_evaluable(pl_arith_error *err, const CHR *name, ULO arity) { if (!err) { return; } err->kind = PL_ARITH_ERR_TYPE_EVALUABLE; err->evaluable_name = name; err->evaluable_arity = arity; } // eval_num_expr_ex() evaluates expressions for is/2 and numeric comparisons in the interpreter. static bool eval_num_expr_ex(const pl_term *expr, const pl_env *env, pl_number *out, pl_arith_error *err, ULO depth, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!expr || !out || (depth > 64)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } expr = (const pl_term *)deref_term((pl_term *)expr, env); if (!expr) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (expr->tag == PL_TERM_VAR) { arith_err_set_culprit(err, PL_ARITH_ERR_INSTANTIATION, expr); return false; } if (expr->tag == PL_TERM_INT) { *out = num_from_int(expr->v.int_value); return true; } if (expr->tag == PL_TERM_BIGINT) { *out = num_from_big(expr->v.bigint); return true; } if (expr->tag == PL_TERM_FLOAT) { *out = num_from_float(expr->v.float_value); return true; } if (expr->tag == PL_TERM_ATOM) { switch ((pl_arith_id)expr->reserved16) { case PL_ARITH_PI_0: *out = num_from_float(acos(-1.0)); return true; case PL_ARITH_E_0: *out = num_from_float(2.718281828459045); return true; case PL_ARITH_EPSILON_0: *out = num_from_float(DBL_EPSILON); return true; default: break; } // Fallback for terms constructed before we cached the arith id. if (expr->v.atom_name) { if (!strcmp(expr->v.atom_name, "pi")) { *out = num_from_float(acos(-1.0)); return true; } if (!strcmp(expr->v.atom_name, "e")) { *out = num_from_float(2.718281828459045); return true; } if (!strcmp(expr->v.atom_name, "epsilon")) { *out = num_from_float(DBL_EPSILON); return true; } } arith_err_set_evaluable(err, expr->v.atom_name, 0); return false; } if (expr->tag != PL_TERM_STRUCT) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } const CHR *fn = expr->v.str.functor; const ULO ar = expr->v.str.arity; const pl_arith_id aid = (pl_arith_id)expr->reserved16; if (aid != PL_ARITH_NONE) { switch (aid) { case PL_ARITH_ADD_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) + num_as_double(b)); } else { if (!num_add_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_ADD_1: return eval_num_expr_ex(expr->v.str.args[0], env, out, err, depth + 1, rt_ctrl, dbg_dat_ptr); case PL_ARITH_SUB_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) - num_as_double(b)); } else { if (!num_sub_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_SUB_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { *out = num_from_float(-a.fval); } else { if (!num_neg_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_MUL_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) * num_as_double(b)); } else { if (!num_mul_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_DIV_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double denom = num_as_double(b); if (denom == 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } *out = num_from_float(num_as_double(a) / denom); return true; } case PL_ARITH_INTDIV_2: { // // pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number q = {0}; const num_div_status st = num_div_mod_int(a, b, false, &q, NULL, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = q; return true; } case PL_ARITH_REM_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number r = {0}; const num_div_status st = num_div_mod_int(a, b, false, NULL, &r, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = r; return true; } case PL_ARITH_DIV_2_FLOOR: { // div pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number q = {0}; const num_div_status st = num_div_mod_int(a, b, true, &q, NULL, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = q; return true; } case PL_ARITH_MOD_2: { // mod pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number r = {0}; const num_div_status st = num_div_mod_int(a, b, true, NULL, &r, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = r; return true; } case PL_ARITH_ABS_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { *out = num_from_float(fabs(a.fval)); } else { if (!num_abs_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_SIGN_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { const double v = a.fval; if (v > 0.0) { *out = num_from_int(1); } else if (v < 0.0) { *out = num_from_int(-1); } else { *out = num_from_int(0); } return true; } if (num_is_big(a)) { const int s = a.big ? a.big->sign : 0; *out = num_from_int(s > 0 ? 1 : (s < 0 ? -1 : 0)); } else { const SLO v = a.ival; *out = num_from_int(v > 0 ? 1 : (v < 0 ? -1 : 0)); } return true; } case PL_ARITH_FLOOR_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = floor(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_CEILING_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = ceil(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_TRUNCATE_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = trunc(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_ROUND_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = floor(a.fval + 0.5); // ISO: floor(X + 1/2) SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_FLOAT_INTEGER_PART_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } *out = num_from_float(trunc(a.fval)); return true; } case PL_ARITH_FLOAT_FRACTIONAL_PART_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = num_from_int(0); return true; } const double ip = trunc(a.fval); *out = num_from_float(a.fval - ip); return true; } case PL_ARITH_FLOAT_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } *out = num_from_float(num_as_double(a)); return true; } case PL_ARITH_MIN_2: case PL_ARITH_MAX_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { const double da = num_as_double(a); const double db = num_as_double(b); *out = num_from_float((aid == PL_ARITH_MIN_2) ? (da < db ? da : db) : (da > db ? da : db)); } else { const int cmp = num_cmp(a, b); if (aid == PL_ARITH_MIN_2) { *out = (cmp <= 0) ? a : b; } else { *out = (cmp >= 0) ? a : b; } } return true; } case PL_ARITH_BNOT_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_bnot_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } case PL_ARITH_BAND_2: case PL_ARITH_BOR_2: case PL_ARITH_BXOR_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } const bigint_bop_kind op = (aid == PL_ARITH_BAND_2) ? BIGINT_BOP_AND : (aid == PL_ARITH_BOR_2) ? BIGINT_BOP_OR : BIGINT_BOP_XOR; if (!num_bitwise_op(a, b, op, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } case PL_ARITH_SHL_2: case PL_ARITH_SHR_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } ULO shift = 0; if (num_is_int(b)) { if (b.ival < 0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } shift = (ULO)b.ival; } else if (num_is_big(b)) { if (!bigint_to_ulo(b.big, &shift)) { const bool a_zero = num_is_big(a) ? bigint_is_zero(a.big) : (a.ival == 0); if (aid == PL_ARITH_SHL_2) { if (a_zero) { *out = num_from_int(0); return true; } arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (a_zero) { *out = num_from_int(0); } else if (num_is_big(a)) { *out = num_from_int(a.big->sign < 0 ? -1 : 0); } else { *out = num_from_int(a.ival < 0 ? -1 : 0); } return true; } } if (aid == PL_ARITH_SHL_2) { if (!num_shift_left(a, shift, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } if (!num_shift_right(a, shift, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } case PL_ARITH_POWF_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double v = pow(num_as_double(a), num_as_double(b)); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } case PL_ARITH_POWI_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_integer(a) && num_is_integer(b)) { const bool exp_is_big = num_is_big(b); bool exp_negative = false; ULO exp_u = 0; SLO exp_s = 0; if (num_is_int(b)) { exp_s = b.ival; exp_negative = (exp_s < 0); if (!exp_negative) { exp_u = (ULO)exp_s; } } else if (exp_is_big) { exp_negative = b.big && (b.big->sign < 0); if (!exp_negative) { if (!bigint_to_ulo(b.big, &exp_u)) { exp_u = 0; } } } bool base_is_zero = false; bool base_is_one = false; bool base_is_minus_one = false; if (num_is_int(a)) { base_is_zero = (a.ival == 0); base_is_one = (a.ival == 1); base_is_minus_one = (a.ival == -1); } else if (num_is_big(a)) { base_is_zero = bigint_is_zero(a.big); base_is_one = (bigint_cmp_slo(a.big, 1) == 0); base_is_minus_one = (bigint_cmp_slo(a.big, -1) == 0); } const bool exp_is_odd = exp_is_big ? (b.big && (b.big->limbs[0] & 1u)) : (exp_s & 1); if (exp_negative) { if (base_is_one) { *out = num_from_int(1); return true; } if (base_is_minus_one) { *out = num_from_int(exp_is_odd ? -1 : 1); return true; } if (base_is_zero) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_FLOAT, deref_term(expr->v.str.args[0], env)); return false; } if (!exp_is_big && num_is_int(a)) { SLO res = 0; if (int_pow_checked(a.ival, exp_s, &res)) { *out = num_from_int(res); return true; } } if (exp_is_big && !bigint_to_ulo(b.big, &exp_u)) { if (base_is_zero) { *out = num_from_int(0); return true; } if (base_is_one) { *out = num_from_int(1); return true; } if (base_is_minus_one) { *out = num_from_int(exp_is_odd ? -1 : 1); return true; } arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (exp_u == 0) { *out = num_from_int(1); return true; } if (base_is_zero) { *out = num_from_int(0); return true; } pl_bigint *base_big = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); if (!base_big) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } pl_bigint *pow = bigint_pow_u64(base_big, (uint64_t)exp_u, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(pow); return true; } const double v = pow(num_as_double(a), num_as_double(b)); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } case PL_ARITH_SIN_1: case PL_ARITH_COS_1: case PL_ARITH_TAN_1: case PL_ARITH_ASIN_1: case PL_ARITH_ACOS_1: case PL_ARITH_ATAN_1: case PL_ARITH_SQRT_1: case PL_ARITH_LOG_1: case PL_ARITH_EXP_1: { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double x = num_as_double(a); double v = 0.0; switch (aid) { case PL_ARITH_SIN_1: v = sin(x); break; case PL_ARITH_COS_1: v = cos(x); break; case PL_ARITH_TAN_1: v = tan(x); break; case PL_ARITH_ASIN_1: v = asin(x); break; case PL_ARITH_ACOS_1: v = acos(x); break; case PL_ARITH_ATAN_1: v = atan(x); break; case PL_ARITH_SQRT_1: if (x < 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } v = sqrt(x); break; case PL_ARITH_LOG_1: if (x <= 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } v = log(x); break; case PL_ARITH_EXP_1: v = exp(x); break; default: return false; } if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } case PL_ARITH_ATAN2_2: { pl_number y = {0}, x = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &y, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &x, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double dy = num_as_double(y); const double dx = num_as_double(x); if ((dy == 0.0) && (dx == 0.0)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } const double v = atan2(dy, dx); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } default: break; } } if (!strcmp(fn, "+") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) + num_as_double(b)); } else { if (!num_add_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } if (!strcmp(fn, "+") && ar == 1) { return eval_num_expr_ex(expr->v.str.args[0], env, out, err, depth + 1, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "-") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) - num_as_double(b)); } else { if (!num_sub_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } if (!strcmp(fn, "-") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { *out = num_from_float(-a.fval); } else { if (!num_neg_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } if (!strcmp(fn, "*") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) * num_as_double(b)); } else { if (!num_mul_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } if (!strcmp(fn, "/") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double denom = num_as_double(b); if (denom == 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } *out = num_from_float(num_as_double(a) / denom); return true; } // Integer bitwise operations (ISO-ish). if (!strcmp(fn, "\\") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_bnot_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } if ((!strcmp(fn, "/\\") || !strcmp(fn, "\\/") || !strcmp(fn, "xor")) && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } const bigint_bop_kind op = !strcmp(fn, "/\\") ? BIGINT_BOP_AND : !strcmp(fn, "\\/") ? BIGINT_BOP_OR : BIGINT_BOP_XOR; if (!num_bitwise_op(a, b, op, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } if ((!strcmp(fn, "<<") || !strcmp(fn, ">>")) && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } ULO shift = 0; if (num_is_int(b)) { if (b.ival < 0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } shift = (ULO)b.ival; } else if (num_is_big(b)) { if (!bigint_to_ulo(b.big, &shift)) { const bool a_zero = num_is_big(a) ? bigint_is_zero(a.big) : (a.ival == 0); if (!strcmp(fn, "<<")) { if (a_zero) { *out = num_from_int(0); return true; } arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (a_zero) { *out = num_from_int(0); } else if (num_is_big(a)) { *out = num_from_int(a.big->sign < 0 ? -1 : 0); } else { *out = num_from_int(a.ival < 0 ? -1 : 0); } return true; } } if (!strcmp(fn, "<<")) { if (!num_shift_left(a, shift, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } if (!num_shift_right(a, shift, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } if (!strcmp(fn, "**") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double v = pow(num_as_double(a), num_as_double(b)); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } if (!strcmp(fn, "^") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_integer(a) && num_is_integer(b)) { const bool exp_is_big = num_is_big(b); bool exp_negative = false; ULO exp_u = 0; SLO exp_s = 0; if (num_is_int(b)) { exp_s = b.ival; exp_negative = (exp_s < 0); if (!exp_negative) { exp_u = (ULO)exp_s; } } else if (exp_is_big) { exp_negative = b.big && (b.big->sign < 0); if (!exp_negative) { if (!bigint_to_ulo(b.big, &exp_u)) { exp_u = 0; } } } bool base_is_zero = false; bool base_is_one = false; bool base_is_minus_one = false; if (num_is_int(a)) { base_is_zero = (a.ival == 0); base_is_one = (a.ival == 1); base_is_minus_one = (a.ival == -1); } else if (num_is_big(a)) { base_is_zero = bigint_is_zero(a.big); base_is_one = (bigint_cmp_slo(a.big, 1) == 0); base_is_minus_one = (bigint_cmp_slo(a.big, -1) == 0); } const bool exp_is_odd = exp_is_big ? (b.big && (b.big->limbs[0] & 1u)) : (exp_s & 1); if (exp_negative) { if (base_is_one) { *out = num_from_int(1); return true; } if (base_is_minus_one) { *out = num_from_int(exp_is_odd ? -1 : 1); return true; } if (base_is_zero) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_FLOAT, deref_term(expr->v.str.args[0], env)); return false; } if (!exp_is_big && num_is_int(a)) { SLO res = 0; if (int_pow_checked(a.ival, exp_s, &res)) { *out = num_from_int(res); return true; } } if (exp_is_big && !bigint_to_ulo(b.big, &exp_u)) { if (base_is_zero) { *out = num_from_int(0); return true; } if (base_is_one) { *out = num_from_int(1); return true; } if (base_is_minus_one) { *out = num_from_int(exp_is_odd ? -1 : 1); return true; } arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (exp_u == 0) { *out = num_from_int(1); return true; } if (base_is_zero) { *out = num_from_int(0); return true; } pl_bigint *base_big = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); if (!base_big) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } pl_bigint *pow = bigint_pow_u64(base_big, (uint64_t)exp_u, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(pow); return true; } const double v = pow(num_as_double(a), num_as_double(b)); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } // Integer arithmetic (ISO-ish). if (!strcmp(fn, "//") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number q = {0}; const num_div_status st = num_div_mod_int(a, b, false, &q, NULL, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = q; return true; } if (!strcmp(fn, "rem") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number r = {0}; const num_div_status st = num_div_mod_int(a, b, false, NULL, &r, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = r; return true; } if (!strcmp(fn, "div") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number q = {0}; const num_div_status st = num_div_mod_int(a, b, true, &q, NULL, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = q; return true; } if (!strcmp(fn, "mod") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[0], env)); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term(expr->v.str.args[1], env)); return false; } pl_number r = {0}; const num_div_status st = num_div_mod_int(a, b, true, NULL, &r, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = r; return true; } if (!strcmp(fn, "floor") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = floor(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } if (!strcmp(fn, "ceiling") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = ceil(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } if (!strcmp(fn, "truncate") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = trunc(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } if (!strcmp(fn, "round") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = floor(a.fval + 0.5); // ISO: floor(X + 1/2) SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } if (!strcmp(fn, "float_integer_part") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } *out = num_from_float(trunc(a.fval)); return true; } if (!strcmp(fn, "float_fractional_part") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = num_from_int(0); return true; } const double i = trunc(a.fval); const double f = a.fval - i; if (!isfinite(f)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(f); return true; } if (!strcmp(fn, "max") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a) && !num_is_float(b)) { const int cmp = num_cmp(a, b); *out = (cmp >= 0) ? a : b; return true; } const double da = num_as_double(a); const double db = num_as_double(b); if (da > db) { *out = a; return true; } if (db > da) { *out = b; return true; } *out = num_from_float(da); return true; } if (!strcmp(fn, "min") && ar == 2) { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a) && !num_is_float(b)) { const int cmp = num_cmp(a, b); *out = (cmp <= 0) ? a : b; return true; } const double da = num_as_double(a); const double db = num_as_double(b); if (da < db) { *out = a; return true; } if (db < da) { *out = b; return true; } *out = num_from_float(da); return true; } if (!strcmp(fn, "abs") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { *out = num_from_float(fabs(a.fval)); } else { if (!num_abs_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } if (!strcmp(fn, "sign") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { const double v = a.fval; const double s = (v > 0.0) ? 1.0 : (v < 0.0) ? -1.0 : 0.0; *out = num_from_float(s); return true; } if (num_is_big(a)) { const int s = a.big ? a.big->sign : 0; *out = num_from_int(s > 0 ? 1 : (s < 0 ? -1 : 0)); } else { const SLO v = a.ival; *out = num_from_int(v > 0 ? 1 : (v < 0 ? -1 : 0)); } return true; } if (!strcmp(fn, "float") && ar == 1) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } *out = num_from_float(num_as_double(a)); return true; } if ((!strcmp(fn, "sin") || !strcmp(fn, "cos") || !strcmp(fn, "tan") || !strcmp(fn, "asin") || !strcmp(fn, "acos") || !strcmp(fn, "atan") || !strcmp(fn, "sqrt") || !strcmp(fn, "log") || !strcmp(fn, "exp")) && (ar == 1)) { pl_number a = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double x = num_as_double(a); double v = 0.0; if (!strcmp(fn, "sin")) { v = sin(x); } else if (!strcmp(fn, "cos")) { v = cos(x); } else if (!strcmp(fn, "tan")) { v = tan(x); } else if (!strcmp(fn, "asin")) { v = asin(x); } else if (!strcmp(fn, "acos")) { v = acos(x); } else if (!strcmp(fn, "atan")) { v = atan(x); } else if (!strcmp(fn, "sqrt")) { if (x < 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } v = sqrt(x); } else if (!strcmp(fn, "log")) { if (x <= 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } v = log(x); } else if (!strcmp(fn, "exp")) { v = exp(x); } else { return false; } if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } if (!strcmp(fn, "atan2") && ar == 2) { pl_number y = {0}, x = {0}; if (!eval_num_expr_ex(expr->v.str.args[0], env, &y, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex(expr->v.str.args[1], env, &x, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double dy = num_as_double(y); const double dx = num_as_double(x); if ((dy == 0.0) && (dx == 0.0)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } const double v = atan2(dy, dx); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } arith_err_set_evaluable(err, fn, ar); return false; } // Arithmetic evaluation for WAM terms. // eval_num_expr_ex_wam() evaluates expressions for is/2 and numeric comparisons. static bool eval_num_expr_ex_wam(const pl_term *expr, pl_number *out, pl_arith_error *err, ULO depth, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!expr || !out || (depth > 64)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } expr = (const pl_term *)deref_term_wam((pl_term *)expr); if (!expr) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (expr->tag == PL_TERM_VAR) { arith_err_set_culprit(err, PL_ARITH_ERR_INSTANTIATION, expr); return false; } if (expr->tag == PL_TERM_INT) { *out = num_from_int(expr->v.int_value); return true; } if (expr->tag == PL_TERM_BIGINT) { *out = num_from_big(expr->v.bigint); return true; } if (expr->tag == PL_TERM_FLOAT) { *out = num_from_float(expr->v.float_value); return true; } if (expr->tag == PL_TERM_ATOM) { switch ((pl_arith_id)expr->reserved16) { case PL_ARITH_PI_0: *out = num_from_float(acos(-1.0)); return true; case PL_ARITH_E_0: *out = num_from_float(2.718281828459045); return true; case PL_ARITH_EPSILON_0: *out = num_from_float(DBL_EPSILON); return true; default: break; } // Fallback for terms constructed before we cached the arith id. if (expr->v.atom_name) { if (!strcmp(expr->v.atom_name, "pi")) { *out = num_from_float(acos(-1.0)); return true; } if (!strcmp(expr->v.atom_name, "e")) { *out = num_from_float(2.718281828459045); return true; } if (!strcmp(expr->v.atom_name, "epsilon")) { *out = num_from_float(DBL_EPSILON); return true; } } arith_err_set_evaluable(err, expr->v.atom_name, 0); return false; } if (expr->tag != PL_TERM_STRUCT) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } const CHR *fn = expr->v.str.functor; const ULO ar = expr->v.str.arity; pl_arith_id aid = (pl_arith_id)expr->reserved16; if ((aid == PL_ARITH_NONE) && fn) { aid = (pl_arith_id)arith_id_from_name_arity(fn, ar); } if (aid != PL_ARITH_NONE) { switch (aid) { case PL_ARITH_ADD_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) + num_as_double(b)); } else { if (!num_add_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_ADD_1: return eval_num_expr_ex_wam(expr->v.str.args[0], out, err, depth + 1, rt_ctrl, dbg_dat_ptr); case PL_ARITH_SUB_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) - num_as_double(b)); } else { if (!num_sub_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_SUB_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { *out = num_from_float(-a.fval); } else { if (!num_neg_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_MUL_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { *out = num_from_float(num_as_double(a) * num_as_double(b)); } else { if (!num_mul_int(a, b, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_DIV_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double denom = num_as_double(b); if (denom == 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } *out = num_from_float(num_as_double(a) / denom); return true; } case PL_ARITH_INTDIV_2: { // // pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[0])); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[1])); return false; } pl_number q = {0}; const num_div_status st = num_div_mod_int(a, b, false, &q, NULL, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = q; return true; } case PL_ARITH_REM_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[0])); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[1])); return false; } pl_number r = {0}; const num_div_status st = num_div_mod_int(a, b, false, NULL, &r, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = r; return true; } case PL_ARITH_DIV_2_FLOOR: { // div pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[0])); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[1])); return false; } pl_number q = {0}; const num_div_status st = num_div_mod_int(a, b, true, &q, NULL, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = q; return true; } case PL_ARITH_MOD_2: { // mod pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[0])); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[1])); return false; } pl_number r = {0}; const num_div_status st = num_div_mod_int(a, b, true, NULL, &r, rt_ctrl, dbg_dat_ptr); if (st == NUM_DIV_ZERO) { arith_err_set(err, PL_ARITH_ERR_EVAL_ZERO_DIVISOR); return false; } if (st != NUM_DIV_OK) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = r; return true; } case PL_ARITH_ABS_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { *out = num_from_float(fabs(a.fval)); } else { if (!num_abs_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } } return true; } case PL_ARITH_SIGN_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a)) { const double v = a.fval; if (v > 0.0) { *out = num_from_int(1); } else if (v < 0.0) { *out = num_from_int(-1); } else { *out = num_from_int(0); } return true; } if (num_is_big(a)) { const int s = a.big ? a.big->sign : 0; *out = num_from_int(s > 0 ? 1 : (s < 0 ? -1 : 0)); } else { const SLO v = a.ival; *out = num_from_int(v > 0 ? 1 : (v < 0 ? -1 : 0)); } return true; } case PL_ARITH_FLOOR_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = floor(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_CEILING_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = ceil(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_TRUNCATE_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = trunc(a.fval); SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_ROUND_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } const double v = floor(a.fval + 0.5); // ISO: floor(X + 1/2) SLO iv = 0; if (!double_to_slo_checked(v, &iv)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_int(iv); return true; } case PL_ARITH_FLOAT_INTEGER_PART_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = a; return true; } *out = num_from_float(trunc(a.fval)); return true; } case PL_ARITH_FLOAT_FRACTIONAL_PART_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_float(a)) { *out = num_from_int(0); return true; } const double ip = trunc(a.fval); *out = num_from_float(a.fval - ip); return true; } case PL_ARITH_FLOAT_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } *out = num_from_float(num_as_double(a)); return true; } case PL_ARITH_MIN_2: case PL_ARITH_MAX_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_float(a) || num_is_float(b)) { const double da = num_as_double(a); const double db = num_as_double(b); *out = num_from_float((aid == PL_ARITH_MIN_2) ? (da < db ? da : db) : (da > db ? da : db)); } else { const int cmp = num_cmp(a, b); if (aid == PL_ARITH_MIN_2) { *out = (cmp <= 0) ? a : b; } else { *out = (cmp >= 0) ? a : b; } } return true; } case PL_ARITH_BNOT_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[0])); return false; } if (!num_bnot_int(a, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } case PL_ARITH_BAND_2: case PL_ARITH_BOR_2: case PL_ARITH_BXOR_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[0])); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[1])); return false; } const bigint_bop_kind op = (aid == PL_ARITH_BAND_2) ? BIGINT_BOP_AND : (aid == PL_ARITH_BOR_2) ? BIGINT_BOP_OR : BIGINT_BOP_XOR; if (!num_bitwise_op(a, b, op, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } case PL_ARITH_SHL_2: case PL_ARITH_SHR_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (!num_is_integer(a)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[0])); return false; } if (!num_is_integer(b)) { arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_INTEGER, deref_term_wam(expr->v.str.args[1])); return false; } ULO shift = 0; if (num_is_int(b)) { if (b.ival < 0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } shift = (ULO)b.ival; } else if (num_is_big(b)) { if (!bigint_to_ulo(b.big, &shift)) { const bool a_zero = num_is_big(a) ? bigint_is_zero(a.big) : (a.ival == 0); if (aid == PL_ARITH_SHL_2) { if (a_zero) { *out = num_from_int(0); return true; } arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (a_zero) { *out = num_from_int(0); } else if (num_is_big(a)) { *out = num_from_int(a.big->sign < 0 ? -1 : 0); } else { *out = num_from_int(a.ival < 0 ? -1 : 0); } return true; } } if (aid == PL_ARITH_SHL_2) { if (!num_shift_left(a, shift, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } if (!num_shift_right(a, shift, out, rt_ctrl, dbg_dat_ptr)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } return true; } case PL_ARITH_POWF_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double v = pow(num_as_double(a), num_as_double(b)); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } case PL_ARITH_POWI_2: { pl_number a = {0}, b = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &b, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } if (num_is_integer(a) && num_is_integer(b)) { const bool exp_is_big = num_is_big(b); bool exp_negative = false; ULO exp_u = 0; SLO exp_s = 0; if (num_is_int(b)) { exp_s = b.ival; exp_negative = (exp_s < 0); if (!exp_negative) { exp_u = (ULO)exp_s; } } else if (exp_is_big) { exp_negative = b.big && (b.big->sign < 0); if (!exp_negative) { if (!bigint_to_ulo(b.big, &exp_u)) { exp_u = 0; } } } bool base_is_zero = false; bool base_is_one = false; bool base_is_minus_one = false; if (num_is_int(a)) { base_is_zero = (a.ival == 0); base_is_one = (a.ival == 1); base_is_minus_one = (a.ival == -1); } else if (num_is_big(a)) { base_is_zero = bigint_is_zero(a.big); base_is_one = (bigint_cmp_slo(a.big, 1) == 0); base_is_minus_one = (bigint_cmp_slo(a.big, -1) == 0); } const bool exp_is_odd = exp_is_big ? (b.big && (b.big->limbs[0] & 1u)) : (exp_s & 1); if (exp_negative) { if (base_is_one) { *out = num_from_int(1); return true; } if (base_is_minus_one) { *out = num_from_int(exp_is_odd ? -1 : 1); return true; } if (base_is_zero) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } arith_err_set_culprit(err, PL_ARITH_ERR_TYPE_FLOAT, deref_term_wam(expr->v.str.args[0])); return false; } if (!exp_is_big && num_is_int(a)) { SLO res = 0; if (int_pow_checked(a.ival, exp_s, &res)) { *out = num_from_int(res); return true; } } if (exp_is_big && !bigint_to_ulo(b.big, &exp_u)) { if (base_is_zero) { *out = num_from_int(0); return true; } if (base_is_one) { *out = num_from_int(1); return true; } if (base_is_minus_one) { *out = num_from_int(exp_is_odd ? -1 : 1); return true; } arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } if (exp_u == 0) { *out = num_from_int(1); return true; } if (base_is_zero) { *out = num_from_int(0); return true; } pl_bigint *base_big = num_to_bigint(a, rt_ctrl, dbg_dat_ptr); if (!base_big) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } pl_bigint *pow = bigint_pow_u64(base_big, (uint64_t)exp_u, rt_ctrl, dbg_dat_ptr); *out = num_from_big_canon(pow); return true; } const double v = pow(num_as_double(a), num_as_double(b)); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } case PL_ARITH_SIN_1: case PL_ARITH_COS_1: case PL_ARITH_TAN_1: case PL_ARITH_ASIN_1: case PL_ARITH_ACOS_1: case PL_ARITH_ATAN_1: case PL_ARITH_SQRT_1: case PL_ARITH_LOG_1: case PL_ARITH_EXP_1: { pl_number a = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &a, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double x = num_as_double(a); double v = 0.0; switch (aid) { case PL_ARITH_SIN_1: v = sin(x); break; case PL_ARITH_COS_1: v = cos(x); break; case PL_ARITH_TAN_1: v = tan(x); break; case PL_ARITH_ASIN_1: v = asin(x); break; case PL_ARITH_ACOS_1: v = acos(x); break; case PL_ARITH_ATAN_1: v = atan(x); break; case PL_ARITH_SQRT_1: if (x < 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } v = sqrt(x); break; case PL_ARITH_LOG_1: if (x <= 0.0) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } v = log(x); break; case PL_ARITH_EXP_1: v = exp(x); break; default: return false; } if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } case PL_ARITH_ATAN2_2: { pl_number y = {0}, x = {0}; if (!eval_num_expr_ex_wam(expr->v.str.args[0], &y, err, depth + 1, rt_ctrl, dbg_dat_ptr) || !eval_num_expr_ex_wam(expr->v.str.args[1], &x, err, depth + 1, rt_ctrl, dbg_dat_ptr)) { return false; } const double dy = num_as_double(y); const double dx = num_as_double(x); if ((dy == 0.0) && (dx == 0.0)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } const double v = atan2(dy, dx); if (!isfinite(v)) { arith_err_set(err, PL_ARITH_ERR_EVAL_UNDEFINED); return false; } *out = num_from_float(v); return true; } default: break; } } arith_err_set_evaluable(err, fn ? fn : "", ar); return false; } static bool unify_terms_subsumes_listlike_fast(pl_term *a, pl_term *b, pl_env *env, const pl_var_list *rigid, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth); static bool unify_terms_subsumes(pl_term *a, pl_term *b, pl_env *env, const pl_var_list *rigid, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } const ULO save = env->count; a = deref_term(a, env); b = deref_term(b, env); a = deref_term((pl_term *)term_peel_pstr_empty_const(a), env); b = deref_term((pl_term *)term_peel_pstr_empty_const(b), env); if (a == b) { return true; } if (a->tag == PL_TERM_VAR) { pl_var_key k = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; if (var_list_contains_key(rigid, k)) { env_rollback(env, save); return false; } pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_tr(k, b, env, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { env_rollback(env, save); return false; } env_bind(env, rt_ctrl, dbg_dat_ptr, a->v.var.scope, a->v.var.var_id, b); return true; } if (b->tag == PL_TERM_VAR) { pl_var_key k = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; if (var_list_contains_key(rigid, k)) { env_rollback(env, save); return false; } pl_var_stack st; var_stack_init(&st); const bool occurs = term_occurs_var_tr(k, a, env, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (occurs) { env_rollback(env, save); return false; } env_bind(env, rt_ctrl, dbg_dat_ptr, b->v.var.scope, b->v.var.var_id, a); return true; } const bool al = term_is_list_like_pair(a); const bool bl = term_is_list_like_pair(b); if (al || bl) { // Treat packed strings as list-equivalent. if (!al || !bl) { env_rollback(env, save); return false; } if (!(term_is_list_pair(a) && term_is_list_pair(b))) { if (!unify_terms_subsumes_listlike_fast(a, b, env, rigid, rt_ctrl, dbg_dat_ptr, depth)) { env_rollback(env, save); return false; } return true; } } if (term_is_integer(a) || term_is_integer(b)) { if (!term_is_integer(a) || !term_is_integer(b) || !term_integer_equal(a, b)) { env_rollback(env, save); return false; } return true; } if (a->tag != b->tag) { env_rollback(env, save); return false; } switch (a->tag) { case PL_TERM_ATOM: if (!strcmp(a->v.atom_name, b->v.atom_name)) { return true; } env_rollback(env, save); return false; case PL_TERM_INT: if (a->v.int_value == b->v.int_value) { return true; } env_rollback(env, save); return false; case PL_TERM_BIGINT: if (term_integer_equal(a, b)) { return true; } env_rollback(env, save); return false; case PL_TERM_FLOAT: if (a->v.float_value == b->v.float_value) { return true; } env_rollback(env, save); return false; case PL_TERM_VAR: return true; case PL_TERM_STRUCT: if ((a->v.str.arity != b->v.str.arity) || strcmp(a->v.str.functor, b->v.str.functor)) { env_rollback(env, save); return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!unify_terms_subsumes(a->v.str.args[i], b->v.str.args[i], env, rigid, rt_ctrl, dbg_dat_ptr, depth + 1)) { env_rollback(env, save); return false; } } return true; default: break; } env_rollback(env, save); return false; } static bool unify_terms_subsumes_listlike_fast(pl_term *a, pl_term *b, pl_env *env, const pl_var_list *rigid, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b || !env || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } pl_term *ca = a; pl_term *cb = b; ULO a_off = 0; ULO b_off = 0; for (ULO guard = 0; !FLOWLOG_DEPTH_LIMIT_REACHED(guard, FLOWLOG_SOLVE_DEPTH_LIMIT); guard++) { ca = deref_term(ca, env); cb = deref_term(cb, env); ca = deref_term((pl_term *)term_peel_pstr_empty_const(ca), env); cb = deref_term((pl_term *)term_peel_pstr_empty_const(cb), env); if (!ca || !cb) { return false; } // If we are in the middle of a packed run, and the offset reached its NUL terminator, // advance to the run tail and continue (no slice allocations). if (ca->tag == PL_TERM_PSTR && ca->v.pstr.bytes) { while (ca->v.pstr.bytes[a_off] == 0) { pl_term *tail = pstr_tail_term_from_nul(ca->v.pstr.bytes + a_off); if (!tail) { return false; } ca = tail; a_off = 0; ca = deref_term(ca, env); ca = deref_term((pl_term *)term_peel_pstr_empty_const(ca), env); if (!ca || ca->tag != PL_TERM_PSTR || !ca->v.pstr.bytes) { break; } } } else { a_off = 0; } if (cb->tag == PL_TERM_PSTR && cb->v.pstr.bytes) { while (cb->v.pstr.bytes[b_off] == 0) { pl_term *tail = pstr_tail_term_from_nul(cb->v.pstr.bytes + b_off); if (!tail) { return false; } cb = tail; b_off = 0; cb = deref_term(cb, env); cb = deref_term((pl_term *)term_peel_pstr_empty_const(cb), env); if (!cb || cb->tag != PL_TERM_PSTR || !cb->v.pstr.bytes) { break; } } } else { b_off = 0; } const bool ca_pstr = term_is_pstr_nonempty(ca); const bool cb_pstr = term_is_pstr_nonempty(cb); const bool ca_list = term_is_list_pair(ca); const bool cb_list = term_is_list_pair(cb); if (!(ca_pstr || ca_list) || !(cb_pstr || cb_list)) { pl_term *a_rem = ca; pl_term *b_rem = cb; if (ca_pstr && a_off) { a_rem = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, ca, a_off); } if (cb_pstr && b_off) { b_rem = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, cb, b_off); } return unify_terms_subsumes(a_rem, b_rem, env, rigid, rt_ctrl, dbg_dat_ptr, depth + 1); } if (ca_pstr && cb_pstr) { const unsigned char *ap = ca->v.pstr.bytes + a_off; const unsigned char *bp = cb->v.pstr.bytes + b_off; while (*ap && *bp) { uint32_t acp = 0; uint32_t bcp = 0; const size_t aused = pstr_decode_one(ap, &acp); const size_t bused = pstr_decode_one(bp, &bcp); if (!aused || !bused || acp != bcp) { break; } ap += aused; bp += bused; } a_off = (ULO)(ap - ca->v.pstr.bytes); b_off = (ULO)(bp - cb->v.pstr.bytes); if (*ap && *bp) { return false; // mismatch } if (*ap == 0) { pl_term *atail = pstr_tail_term_from_nul(ap); if (!atail) { return false; } ca = atail; a_off = 0; } if (*bp == 0) { pl_term *btail = pstr_tail_term_from_nul(bp); if (!btail) { return false; } cb = btail; b_off = 0; } continue; } if (ca_pstr) { uint32_t ch = 0; const unsigned char *ap = ca->v.pstr.bytes + a_off; const size_t used = pstr_decode_one(ap, &ch); if (!used) { return false; } pl_term *char_atom = make_char_atom_rt(dbg_dat_ptr, ch); pl_term *bh = cb->v.str.args[0]; if (!unify_terms_subsumes(char_atom, bh, env, rigid, rt_ctrl, dbg_dat_ptr, depth + 1)) { return false; } a_off += (ULO)used; cb = cb->v.str.args[1]; continue; } // cb_pstr uint32_t ch = 0; const unsigned char *bp = cb->v.pstr.bytes + b_off; const size_t used = pstr_decode_one(bp, &ch); if (!used) { return false; } pl_term *char_atom = make_char_atom_rt(dbg_dat_ptr, ch); pl_term *ah = ca->v.str.args[0]; if (!unify_terms_subsumes(ah, char_atom, env, rigid, rt_ctrl, dbg_dat_ptr, depth + 1)) { return false; } b_off += (ULO)used; ca = ca->v.str.args[1]; } return false; } /* ============================================================================ * SECTION 16: Term Order & Comparison * standard term order comparisons and related helpers. * ============================================================================ */ /* --- SUBSECTION 16.1: Interpreter Term Ordering -------------------------- */ // Interpreter term ordering helpers. // term_order_rank() and compare_std_terms_env() implement standard order for compare/3 and sorting. static int term_order_rank(const pl_term *t) { if (!t) { return 100; } if (t->tag == PL_TERM_VAR) { return 0; } if (t->tag == PL_TERM_INT || t->tag == PL_TERM_BIGINT || t->tag == PL_TERM_FLOAT) { return 1; } if (t->tag == PL_TERM_ATOM) { return 2; } return 3; } static int compare_std_terms(pl_term *a, pl_term *b, const pl_env *env, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth); static int compare_std_terms_listlike(pl_term *a, pl_term *b, const pl_env *env, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b) { return 0; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return 0; } a = (pl_term *)term_peel_pstr_empty_const(a); b = (pl_term *)term_peel_pstr_empty_const(b); if (!a || !b) { return 0; } const bool a_pstr = term_is_list_like_pair(a) && !term_is_list_pair(a); const bool b_pstr = term_is_list_like_pair(b) && !term_is_list_pair(b); const ULO a_arity = a_pstr ? 2 : a->v.str.arity; const ULO b_arity = b_pstr ? 2 : b->v.str.arity; if (a_arity != b_arity) { return (a_arity < b_arity) ? -1 : 1; } const CHR *a_functor = a_pstr ? "." : a->v.str.functor; const CHR *b_functor = b_pstr ? "." : b->v.str.functor; int c = strcmp(a_functor ? a_functor : "", b_functor ? b_functor : ""); if (c < 0) { return -1; } if (c > 0) { return 1; } const pl_term *a_head = NULL; const pl_term *a_tail = NULL; pl_term a_head_tmp = {0}; CHR a_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term a_tail_tmp = {0}; if (a_pstr) { if (!term_list_like_uncons_view(a, &a_head, &a_tail, &a_head_tmp, a_head_ch, &a_tail_tmp) || !a_head || !a_tail) { return 0; } } const pl_term *b_head = NULL; const pl_term *b_tail = NULL; pl_term b_head_tmp = {0}; CHR b_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term b_tail_tmp = {0}; if (b_pstr) { if (!term_list_like_uncons_view(b, &b_head, &b_tail, &b_head_tmp, b_head_ch, &b_tail_tmp) || !b_head || !b_tail) { return 0; } } for (ULO i = 0; i < a_arity; i++) { pl_term *aa = a_pstr ? (pl_term *)(i ? a_tail : a_head) : a->v.str.args[i]; pl_term *bb = b_pstr ? (pl_term *)(i ? b_tail : b_head) : b->v.str.args[i]; int r = compare_std_terms(aa, bb, env, st, dbg_dat_ptr, depth + 1); if (r) { return r; } } return 0; } static int compare_std_terms(pl_term *a, pl_term *b, const pl_env *env, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { (void)dbg_dat_ptr; if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return 0; } if (a == b) { return 0; } retry: if (a && (a->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_term *ab = env_binding_for_var(env, a); if (ab && !var_stack_contains(st, k)) { var_stack_push(st, dbg_dat_ptr, k); int r = compare_std_terms(ab, b, env, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return r; } } if (b && (b->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_term *bb = env_binding_for_var(env, b); if (bb && !var_stack_contains(st, k)) { var_stack_push(st, dbg_dat_ptr, k); int r = compare_std_terms(a, bb, env, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return r; } } pl_term *a_peel = (pl_term *)term_peel_pstr_empty_const(a); pl_term *b_peel = (pl_term *)term_peel_pstr_empty_const(b); if ((a_peel != a) || (b_peel != b)) { a = a_peel; b = b_peel; if (a == b) { return 0; } goto retry; } const int ra = term_order_rank(a); const int rb = term_order_rank(b); if (ra != rb) { return (ra < rb) ? -1 : 1; } if (!a || !b) { return 0; } if (term_is_number(a) && term_is_number(b)) { const pl_number na = (a->tag == PL_TERM_FLOAT) ? num_from_float(a->v.float_value) : (a->tag == PL_TERM_BIGINT) ? num_from_big(a->v.bigint) : num_from_int(a->v.int_value); const pl_number nb = (b->tag == PL_TERM_FLOAT) ? num_from_float(b->v.float_value) : (b->tag == PL_TERM_BIGINT) ? num_from_big(b->v.bigint) : num_from_int(b->v.int_value); const int cmp = num_cmp(na, nb); if (cmp) { return cmp; } // ISO (per INRIA suite): floats sort before integers when the numeric values are equal. const bool a_float = (a->tag == PL_TERM_FLOAT); const bool b_float = (b->tag == PL_TERM_FLOAT); if (a_float != b_float) { return a_float ? -1 : 1; } return 0; } if ((term_is_list_like_pair(a) && !term_is_list_pair(a)) || (term_is_list_like_pair(b) && !term_is_list_pair(b))) { return compare_std_terms_listlike(a, b, env, st, dbg_dat_ptr, depth); } switch (a->tag) { case PL_TERM_VAR: { const uintptr_t sa = (uintptr_t)a->v.var.scope; const uintptr_t sb = (uintptr_t)b->v.var.scope; if (sa != sb) { return (sa < sb) ? -1 : 1; } if (a->v.var.var_id == b->v.var.var_id) { return 0; } return (a->v.var.var_id < b->v.var.var_id) ? -1 : 1; } case PL_TERM_INT: if (a->v.int_value == b->v.int_value) { return 0; } return (a->v.int_value < b->v.int_value) ? -1 : 1; case PL_TERM_BIGINT: { const int cmp = term_integer_cmp(a, b); if (cmp < 0) { return -1; } if (cmp > 0) { return 1; } return 0; } case PL_TERM_FLOAT: if (a->v.float_value == b->v.float_value) { return 0; } return (a->v.float_value < b->v.float_value) ? -1 : 1; case PL_TERM_ATOM: { int c = strcmp(a->v.atom_name, b->v.atom_name); if (c < 0) { return -1; } if (c > 0) { return 1; } return 0; } case PL_TERM_STRUCT: { if (a->v.str.arity != b->v.str.arity) { return (a->v.str.arity < b->v.str.arity) ? -1 : 1; } int c = strcmp(a->v.str.functor, b->v.str.functor); if (c < 0) { return -1; } if (c > 0) { return 1; } for (ULO i = 0; i < a->v.str.arity; i++) { int r = compare_std_terms(a->v.str.args[i], b->v.str.args[i], env, st, dbg_dat_ptr, depth + 1); if (r) { return r; } } return 0; } default: return 0; } return 0; } static int compare_std_terms_env(pl_term *a, pl_term *b, const pl_env *env, const ULO *dbg_dat_ptr) { pl_var_stack st; var_stack_init(&st); const int r = compare_std_terms(a, b, env, &st, dbg_dat_ptr, 0); var_stack_free(&st); return r; } /* --- SUBSECTION 16.2: WAM Term Ordering ---------------------------------- */ // WAM term ordering helpers. // compare_std_terms_wam_listlike()/compare_std_terms_wam_tr() compare list-like terms; qsort_pl_term_ptr_cmp_wam() bridges to qsort. static int compare_std_terms_wam_tr(pl_term *a, pl_term *b, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth); static int compare_std_terms_wam_listlike(pl_term *a, pl_term *b, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b) { return 0; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return 0; } a = (pl_term *)term_peel_pstr_empty_const(a); b = (pl_term *)term_peel_pstr_empty_const(b); if (!a || !b) { return 0; } const bool a_pstr = term_is_list_like_pair(a) && !term_is_list_pair(a); const bool b_pstr = term_is_list_like_pair(b) && !term_is_list_pair(b); const ULO a_arity = a_pstr ? 2 : a->v.str.arity; const ULO b_arity = b_pstr ? 2 : b->v.str.arity; if (a_arity != b_arity) { return (a_arity < b_arity) ? -1 : 1; } const CHR *a_functor = a_pstr ? "." : a->v.str.functor; const CHR *b_functor = b_pstr ? "." : b->v.str.functor; int c = strcmp(a_functor ? a_functor : "", b_functor ? b_functor : ""); if (c < 0) { return -1; } if (c > 0) { return 1; } const pl_term *a_head = NULL; const pl_term *a_tail = NULL; pl_term a_head_tmp = {0}; CHR a_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term a_tail_tmp = {0}; if (a_pstr) { if (!term_list_like_uncons_view(a, &a_head, &a_tail, &a_head_tmp, a_head_ch, &a_tail_tmp) || !a_head || !a_tail) { return 0; } } const pl_term *b_head = NULL; const pl_term *b_tail = NULL; pl_term b_head_tmp = {0}; CHR b_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term b_tail_tmp = {0}; if (b_pstr) { if (!term_list_like_uncons_view(b, &b_head, &b_tail, &b_head_tmp, b_head_ch, &b_tail_tmp) || !b_head || !b_tail) { return 0; } } for (ULO i = 0; i < a_arity; i++) { pl_term *aa = a_pstr ? (pl_term *)(i ? a_tail : a_head) : a->v.str.args[i]; pl_term *bb = b_pstr ? (pl_term *)(i ? b_tail : b_head) : b->v.str.args[i]; int r = compare_std_terms_wam_tr(aa, bb, st, dbg_dat_ptr, depth + 1); if (r) { return r; } } return 0; } static int compare_std_terms_wam_tr(pl_term *a, pl_term *b, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { (void)dbg_dat_ptr; if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return 0; } retry: if (a == b) { return 0; } if (a && (a->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_term *ab = wam_binding_for_var(a); if (ab && !var_stack_contains(st, k)) { var_stack_push(st, dbg_dat_ptr, k); int r = compare_std_terms_wam_tr(ab, b, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return r; } } if (b && (b->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_term *bb = wam_binding_for_var(b); if (bb && !var_stack_contains(st, k)) { var_stack_push(st, dbg_dat_ptr, k); int r = compare_std_terms_wam_tr(a, bb, st, dbg_dat_ptr, depth + 1); var_stack_pop(st); return r; } } const pl_term *ap = term_peel_pstr_empty_const(a); if (ap && (ap != a)) { a = (pl_term *)ap; goto retry; } const pl_term *bp = term_peel_pstr_empty_const(b); if (bp && (bp != b)) { b = (pl_term *)bp; goto retry; } const int ra = term_order_rank(a); const int rb = term_order_rank(b); if (ra != rb) { return (ra < rb) ? -1 : 1; } if (!a || !b) { return 0; } if (term_is_number(a) && term_is_number(b)) { const pl_number na = (a->tag == PL_TERM_FLOAT) ? num_from_float(a->v.float_value) : (a->tag == PL_TERM_BIGINT) ? num_from_big(a->v.bigint) : num_from_int(a->v.int_value); const pl_number nb = (b->tag == PL_TERM_FLOAT) ? num_from_float(b->v.float_value) : (b->tag == PL_TERM_BIGINT) ? num_from_big(b->v.bigint) : num_from_int(b->v.int_value); const int cmp = num_cmp(na, nb); if (cmp) { return cmp; } // ISO (per INRIA suite): floats sort before integers when the numeric values are equal. const bool a_float = (a->tag == PL_TERM_FLOAT); const bool b_float = (b->tag == PL_TERM_FLOAT); if (a_float != b_float) { return a_float ? -1 : 1; } return 0; } if ((term_is_list_like_pair(a) && !term_is_list_pair(a)) || (term_is_list_like_pair(b) && !term_is_list_pair(b))) { return compare_std_terms_wam_listlike(a, b, st, dbg_dat_ptr, depth); } switch (a->tag) { case PL_TERM_VAR: { const uintptr_t sa = (uintptr_t)a->v.var.scope; const uintptr_t sb = (uintptr_t)b->v.var.scope; if (sa != sb) { return (sa < sb) ? -1 : 1; } if (a->v.var.var_id == b->v.var.var_id) { return 0; } return (a->v.var.var_id < b->v.var.var_id) ? -1 : 1; } case PL_TERM_INT: if (a->v.int_value == b->v.int_value) { return 0; } return (a->v.int_value < b->v.int_value) ? -1 : 1; case PL_TERM_BIGINT: { const int cmp = term_integer_cmp(a, b); if (cmp < 0) { return -1; } if (cmp > 0) { return 1; } return 0; } case PL_TERM_FLOAT: if (a->v.float_value == b->v.float_value) { return 0; } return (a->v.float_value < b->v.float_value) ? -1 : 1; case PL_TERM_ATOM: { int c = strcmp(a->v.atom_name, b->v.atom_name); if (c < 0) { return -1; } if (c > 0) { return 1; } return 0; } case PL_TERM_STRUCT: { if (a->v.str.arity != b->v.str.arity) { return (a->v.str.arity < b->v.str.arity) ? -1 : 1; } int c = strcmp(a->v.str.functor, b->v.str.functor); if (c < 0) { return -1; } if (c > 0) { return 1; } for (ULO i = 0; i < a->v.str.arity; i++) { int r = compare_std_terms_wam_tr(a->v.str.args[i], b->v.str.args[i], st, dbg_dat_ptr, depth + 1); if (r) { return r; } } return 0; } default: return 0; } return 0; } static int compare_std_terms_wam(pl_term *a, pl_term *b, const ULO *dbg_dat_ptr) { pl_var_stack st; var_stack_init(&st); const int r = compare_std_terms_wam_tr(a, b, &st, dbg_dat_ptr, 0); var_stack_free(&st); return r; } static FLOWLOG_TLS const ULO *g_qsort_wam_dbg_dat_ptr = NULL; static int qsort_pl_term_ptr_cmp_wam(const void *pa, const void *pb) { pl_term *a = *(pl_term *const *)pa; pl_term *b = *(pl_term *const *)pb; return compare_std_terms_wam(a, b, g_qsort_wam_dbg_dat_ptr); } static bool term_variant_wam_tr(pl_term *a, pl_term *b, pl_var_stack *st_a, pl_var_stack *st_b, pl_variant_map *m, const ULO *dbg_dat_ptr, ULO depth) { if (!a || !b || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } retry: if (a == b) { return true; } if (a->tag == PL_TERM_VAR) { pl_var_key ka = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_term *ab = wam_binding_for_var(a); if (ab && !var_stack_contains(st_a, ka)) { var_stack_push(st_a, dbg_dat_ptr, ka); bool ok = term_variant_wam_tr(ab, b, st_a, st_b, m, dbg_dat_ptr, depth + 1); var_stack_pop(st_a); return ok; } } if (b->tag == PL_TERM_VAR) { pl_var_key kb = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_term *bb = wam_binding_for_var(b); if (bb && !var_stack_contains(st_b, kb)) { var_stack_push(st_b, dbg_dat_ptr, kb); bool ok = term_variant_wam_tr(a, bb, st_a, st_b, m, dbg_dat_ptr, depth + 1); var_stack_pop(st_b); return ok; } } const pl_term *ap = term_peel_pstr_empty_const(a); if (ap && (ap != a)) { a = (pl_term *)ap; goto retry; } const pl_term *bp = term_peel_pstr_empty_const(b); if (bp && (bp != b)) { b = (pl_term *)bp; goto retry; } const bool al = term_is_list_like_pair(a); const bool bl = term_is_list_like_pair(b); if (al || bl) { if (!al || !bl) { return false; } const pl_term *ah = NULL; const pl_term *at = NULL; pl_term a_head_tmp = {0}; CHR a_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term a_tail_tmp = {0}; const pl_term *bh = NULL; const pl_term *bt = NULL; pl_term b_head_tmp = {0}; CHR b_head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term b_tail_tmp = {0}; if (!term_list_like_uncons_view(a, &ah, &at, &a_head_tmp, a_head_ch, &a_tail_tmp) || !term_list_like_uncons_view(b, &bh, &bt, &b_head_tmp, b_head_ch, &b_tail_tmp) || !ah || !at || !bh || !bt) { return false; } return term_variant_wam_tr((pl_term *)ah, (pl_term *)bh, st_a, st_b, m, dbg_dat_ptr, depth + 1) && term_variant_wam_tr((pl_term *)at, (pl_term *)bt, st_a, st_b, m, dbg_dat_ptr, depth + 1); } if (term_is_integer(a) || term_is_integer(b)) { return term_is_integer(a) && term_is_integer(b) && term_integer_equal(a, b); } if (a->tag != b->tag) { return false; } switch (a->tag) { case PL_TERM_VAR: { pl_var_key ka = {.scope = a->v.var.scope, .var_id = a->v.var.var_id}; pl_var_key kb = {.scope = b->v.var.scope, .var_id = b->v.var.var_id}; pl_var_key mapped = {0}; if (variant_map_lookup_a(m, ka, &mapped)) { return var_key_eq(mapped, kb); } if (variant_map_lookup_b(m, kb, NULL)) { return false; } variant_map_add(m, dbg_dat_ptr, ka, kb); return true; } case PL_TERM_ATOM: return !strcmp(a->v.atom_name, b->v.atom_name); case PL_TERM_INT: return a->v.int_value == b->v.int_value; case PL_TERM_BIGINT: return term_integer_equal(a, b); case PL_TERM_FLOAT: return a->v.float_value == b->v.float_value; case PL_TERM_STRUCT: if ((a->v.str.arity != b->v.str.arity) || strcmp(a->v.str.functor, b->v.str.functor)) { return false; } for (ULO i = 0; i < a->v.str.arity; i++) { if (!term_variant_wam_tr(a->v.str.args[i], b->v.str.args[i], st_a, st_b, m, dbg_dat_ptr, depth + 1)) { return false; } } return true; default: break; } return false; } static bool term_variant_wam(pl_term *a, pl_term *b, const ULO *dbg_dat_ptr) { pl_var_stack st_a; pl_var_stack st_b; pl_variant_map m = {0}; var_stack_init(&st_a); var_stack_init(&st_b); variant_map_init(&m); const bool ok = term_variant_wam_tr(a, b, &st_a, &st_b, &m, dbg_dat_ptr, 0); variant_map_free(&m); var_stack_free(&st_b); var_stack_free(&st_a); return ok; } static FLOWLOG_TLS const pl_env *g_qsort_env = NULL; static FLOWLOG_TLS const ULO *g_qsort_dbg_dat_ptr = NULL; static int qsort_pl_term_ptr_cmp(const void *pa, const void *pb) { pl_term *a = *(pl_term *const *)pa; pl_term *b = *(pl_term *const *)pb; return compare_std_terms_env(a, b, g_qsort_env, g_qsort_dbg_dat_ptr); } typedef struct { pl_var_key key; pl_term *var; bool binding_copied; } pl_copy_var_entry; typedef struct { pl_copy_var_entry *items; ULO count; ULO cap; ULO next_var_id; const pl_scope *scope; } pl_copy_var_map; static void copy_var_map_init(pl_copy_var_map *m, const pl_scope *scope) { memset(m, 0, sizeof(*m)); m->scope = scope; } static void copy_var_map_free(pl_copy_var_map *m) { free(m->items); memset(m, 0, sizeof(*m)); } static pl_copy_var_entry *copy_var_map_get(pl_copy_var_map *m, const ULO *dbg_dat_ptr, pl_var_key k) { for (ULO i = 0; i < m->count; i++) { if (var_key_eq(m->items[i].key, k)) { return &m->items[i]; } } if (m->count == m->cap) { ULO new_cap = m->cap ? (m->cap * 2) : 64; pl_copy_var_entry *new_items = (pl_copy_var_entry *)realloc(m->items, sizeof(pl_copy_var_entry) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } m->items = new_items; m->cap = new_cap; } m->items[m->count] = (pl_copy_var_entry){.key = k, .var = NULL, .binding_copied = false}; return &m->items[m->count++]; } static pl_term *copy_term_tr(pl_term *t, const pl_env *env_in, pl_env *env_out, pl_copy_var_map *m, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return NULL; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return NULL; } if (t->tag == PL_TERM_VAR) { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; pl_copy_var_entry *e = copy_var_map_get(m, dbg_dat_ptr, k); if (!e->var) { e->var = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, m->scope, m->next_var_id++); } if (!e->binding_copied) { e->binding_copied = true; pl_term *b = env_binding_for_var(env_in, t); if (b) { pl_term *bc = copy_term_tr(b, env_in, env_out, m, rt_ctrl, dbg_dat_ptr, depth + 1); env_bind(env_out, rt_ctrl, dbg_dat_ptr, m->scope, e->var->v.var.var_id, bc); } } return e->var; } const unsigned char *pbytes = NULL; ULO plen = 0; const pl_term *ptail = NULL; if (term_pstr_run_bytes_len_tail_const(t, &pbytes, &plen, &ptail)) { pl_term *tail_c = ptail ? copy_term_tr((pl_term *)ptail, env_in, env_out, m, rt_ctrl, dbg_dat_ptr, depth + 1) : NULL; if (!tail_c) { tail_c = make_nil_rt(dbg_dat_ptr); } return make_pstr_bytes_rt(rt_ctrl, dbg_dat_ptr, pbytes, plen, tail_c); } switch (t->tag) { case PL_TERM_ATOM: return make_atom_rt(rt_ctrl, dbg_dat_ptr, t->v.atom_name); case PL_TERM_INT: return make_int_rt(rt_ctrl, dbg_dat_ptr, t->v.int_value); case PL_TERM_BIGINT: return make_bigint_rt(rt_ctrl, dbg_dat_ptr, t->v.bigint); case PL_TERM_FLOAT: return make_float_rt(rt_ctrl, dbg_dat_ptr, t->v.float_value); case PL_TERM_STRUCT: { pl_term *st = make_struct_rt(rt_ctrl, dbg_dat_ptr, t->v.str.functor, t->v.str.arity); for (ULO i = 0; i < t->v.str.arity; i++) { st->v.str.args[i] = copy_term_tr(t->v.str.args[i], env_in, env_out, m, rt_ctrl, dbg_dat_ptr, depth + 1); } return st; } case PL_TERM_VAR: return NULL; default: return NULL; } return NULL; } typedef struct { pl_copy_var_map map; pl_term **bindings; // indexed by destination var_id (may be NULL when cap==0) ULO bindings_cap; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_wam_copy_ctx; // Return a representative variable for an alias chain. // // In the WAM-lite representation, variable-to-variable bindings form chains: // X -> Y -> ... -> (unbound var | nonvar term). // // For copy_term/2 and friends we want all aliases to map to the same copied // variable/value, so we use the last variable in the chain as the key. static pl_term *wam_var_rep(pl_term *t) { pl_term *cur = t; for (ULO guard = 0; cur && (cur->tag == PL_TERM_VAR) && (guard < 65536); guard++) { pl_wam_cell *cell = wam_cell_for_var(cur); if (!cell || !cell->value) { return cur; // unbound } pl_term *v = cell->value; if (!v || (v->tag != PL_TERM_VAR) || (v == cur)) { return cur; // bound to non-var (or self) } cur = v; } return cur; } static pl_term *copy_term_wam_tr(pl_term *t, pl_wam_copy_ctx *ctx, ULO depth) { if (!t || !ctx || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return NULL; } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return NULL; } if (t->tag == PL_TERM_VAR) { pl_term *rep = wam_var_rep(t); if (!rep || (rep->tag != PL_TERM_VAR)) { return NULL; } pl_var_key k = {.scope = rep->v.var.scope, .var_id = rep->v.var.var_id}; pl_copy_var_entry *e = copy_var_map_get(&ctx->map, ctx->dbg_dat_ptr, k); if (e->var) { return e->var; } pl_wam_cell *cell = wam_cell_for_var(rep); pl_term *b = (cell && cell->value) ? cell->value : NULL; if (!b) { // Unbound representative variable: create a fresh variable in the output scope. e->var = make_fresh_var_rt(ctx->rt_ctrl, ctx->dbg_dat_ptr, ctx->map.scope, ctx->map.next_var_id++); return e->var; } // Bound representative variable: copy its bound value and memoize so // repeated occurrences preserve sharing (and avoid introducing cycles). pl_term *bc = copy_term_wam_tr(b, ctx, depth + 1); e->var = bc; return bc; } const unsigned char *pbytes = NULL; ULO plen = 0; const pl_term *ptail = NULL; if (term_pstr_run_bytes_len_tail_const(t, &pbytes, &plen, &ptail)) { pl_term *tail_c = ptail ? copy_term_wam_tr((pl_term *)ptail, ctx, depth + 1) : NULL; if (!tail_c) { tail_c = make_nil_rt(ctx->dbg_dat_ptr); } return make_pstr_bytes_rt(ctx->rt_ctrl, ctx->dbg_dat_ptr, pbytes, plen, tail_c); } switch (t->tag) { case PL_TERM_ATOM: return make_atom_rt(ctx->rt_ctrl, ctx->dbg_dat_ptr, t->v.atom_name); case PL_TERM_INT: return make_int_rt(ctx->rt_ctrl, ctx->dbg_dat_ptr, t->v.int_value); case PL_TERM_BIGINT: return make_bigint_rt(ctx->rt_ctrl, ctx->dbg_dat_ptr, t->v.bigint); case PL_TERM_FLOAT: return make_float_rt(ctx->rt_ctrl, ctx->dbg_dat_ptr, t->v.float_value); case PL_TERM_STRUCT: { pl_term *st = make_struct_rt(ctx->rt_ctrl, ctx->dbg_dat_ptr, t->v.str.functor, t->v.str.arity); for (ULO i = 0; i < t->v.str.arity; i++) { st->v.str.args[i] = copy_term_wam_tr(t->v.str.args[i], ctx, depth + 1); } return st; } case PL_TERM_VAR: return NULL; default: return NULL; } return NULL; } /* ============================================================================ * SECTION 17: Term Writer & Reader * output buffers, term printers, and read/write helpers. * ============================================================================ */ /* --- SUBSECTION 17.1: String Buffers ------------------------------------- */ // String buffer utilities for building output. // sbuf_init()/sbuf_reserve()/sbuf_append_mem() manage dynamic buffers used by printers, REPL, and error reporting. typedef struct pl_sbuf { char *buf; size_t len; size_t cap; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_sbuf; static void sbuf_init(pl_sbuf *sb, const void *rt_ctrl, const ULO *dbg_dat_ptr) { sb->buf = NULL; sb->len = 0; sb->cap = 0; sb->rt_ctrl = rt_ctrl; sb->dbg_dat_ptr = dbg_dat_ptr; } static void sbuf_free(pl_sbuf *sb) { free(sb->buf); sb->buf = NULL; sb->len = 0; sb->cap = 0; sb->rt_ctrl = NULL; sb->dbg_dat_ptr = NULL; } static void sbuf_reserve(pl_sbuf *sb, size_t add) { size_t need = sb->len + add + 1; if (need <= sb->cap) { return; } size_t new_cap = sb->cap ? sb->cap : 64; while (new_cap < need) { new_cap *= 2; } char *new_buf = (char *)realloc(sb->buf, new_cap); if (!new_buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", sb->dbg_dat_ptr); } sb->buf = new_buf; sb->cap = new_cap; } static void sbuf_append_mem(pl_sbuf *sb, const char *s, size_t n) { sbuf_reserve(sb, n); memcpy(sb->buf + sb->len, s, n); sb->len += n; sb->buf[sb->len] = '\0'; } static void sbuf_append_cstr(pl_sbuf *sb, const char *s) { sbuf_append_mem(sb, s, strlen(s)); } static void sbuf_append_char(pl_sbuf *sb, char c) { sbuf_reserve(sb, 1); sb->buf[sb->len++] = c; sb->buf[sb->len] = '\0'; } static inline void sbuf_clear(pl_sbuf *sb) { if (!sb) { return; } sb->len = 0; if (sb->buf) { sb->buf[0] = '\0'; } } /* --- SUBSECTION 17.2: REPL Solution Streaming --------------------------- */ #define FLOWLOG_REPL_SOLUTION_QUEUE_CAP 64 #define FLOWLOG_REPL_BATCH_SIZE 5 #define FLOWLOG_REPL_STREAM_POLL_MS 80 typedef struct { char *buf; size_t len; bool has_solution; } pl_solution_item; struct pl_solution_span { size_t start; size_t end; }; struct pl_solution_stream { pthread_mutex_t mu; pthread_cond_t cv_item; pthread_cond_t cv_space; pthread_cond_t cv_permit; pl_solution_item *items; size_t cap; size_t count; size_t head; size_t tail; size_t permit; size_t pending_solutions; bool streaming; bool stop; bool done; pl_sbuf pending_io; // solver-thread only; prepended before next solution }; struct pl_solution_capture { pl_sbuf *out; pl_solution_span *spans; ULO count; ULO cap; bool retain_output; pl_solution_stream *stream; }; static bool solution_stream_init(pl_solution_stream *st, size_t cap, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!st) { return false; } memset(st, 0, sizeof(*st)); if (!cap) { cap = FLOWLOG_REPL_SOLUTION_QUEUE_CAP; } st->items = (pl_solution_item *)calloc(cap, sizeof(*st->items)); if (!st->items) { return false; } st->cap = cap; st->permit = FLOWLOG_REPL_BATCH_SIZE; // allow an initial batch by default sbuf_init(&st->pending_io, rt_ctrl, dbg_dat_ptr); if (pthread_mutex_init(&st->mu, NULL) != 0) { free(st->items); st->items = NULL; return false; } if (pthread_cond_init(&st->cv_item, NULL) != 0 || pthread_cond_init(&st->cv_space, NULL) != 0 || pthread_cond_init(&st->cv_permit, NULL) != 0) { pthread_mutex_destroy(&st->mu); free(st->items); st->items = NULL; return false; } return true; } static bool solution_stream_grow_locked(pl_solution_stream *st) { if (!st || !st->items) { return false; } size_t new_cap = st->cap ? (st->cap * 2) : FLOWLOG_REPL_SOLUTION_QUEUE_CAP; if (new_cap < st->cap) { return false; } pl_solution_item *next = (pl_solution_item *)calloc(new_cap, sizeof(*next)); if (!next) { return false; } for (size_t i = 0; i < st->count; i++) { size_t idx = (st->head + i) % st->cap; next[i] = st->items[idx]; } free(st->items); st->items = next; st->cap = new_cap; st->head = 0; st->tail = st->count; return true; } static void solution_stream_free(pl_solution_stream *st) { if (!st) { return; } if (st->items) { for (size_t i = 0; i < st->count; i++) { size_t idx = (st->head + i) % st->cap; free(st->items[idx].buf); st->items[idx].buf = NULL; } free(st->items); st->items = NULL; } sbuf_free(&st->pending_io); (void)pthread_cond_destroy(&st->cv_item); (void)pthread_cond_destroy(&st->cv_space); (void)pthread_cond_destroy(&st->cv_permit); (void)pthread_mutex_destroy(&st->mu); } static void solution_stream_stop(pl_solution_stream *st) { if (!st) { return; } (void)pthread_mutex_lock(&st->mu); st->stop = true; for (size_t i = 0; i < st->count; i++) { size_t idx = (st->head + i) % st->cap; free(st->items[idx].buf); st->items[idx].buf = NULL; } st->count = 0; st->head = 0; st->tail = 0; st->pending_solutions = 0; (void)pthread_cond_broadcast(&st->cv_item); (void)pthread_cond_broadcast(&st->cv_space); (void)pthread_cond_broadcast(&st->cv_permit); (void)pthread_mutex_unlock(&st->mu); } static void solution_stream_mark_done(pl_solution_stream *st) { if (!st) { return; } (void)pthread_mutex_lock(&st->mu); st->done = true; (void)pthread_cond_broadcast(&st->cv_item); (void)pthread_cond_broadcast(&st->cv_permit); (void)pthread_mutex_unlock(&st->mu); } static void solution_stream_allow_more(pl_solution_stream *st, size_t n) { if (!st || n == 0) { return; } (void)pthread_mutex_lock(&st->mu); st->permit += n; (void)pthread_cond_broadcast(&st->cv_permit); (void)pthread_mutex_unlock(&st->mu); } static void solution_stream_enable_streaming(pl_solution_stream *st) { if (!st) { return; } (void)pthread_mutex_lock(&st->mu); st->streaming = true; (void)pthread_cond_broadcast(&st->cv_permit); (void)pthread_mutex_unlock(&st->mu); } static bool solution_stream_can_deliver(pl_solution_stream *st) { if (!st) { return true; } bool ok = false; (void)pthread_mutex_lock(&st->mu); if (st->streaming || (st->permit > 0)) { ok = true; } (void)pthread_mutex_unlock(&st->mu); return ok; } static bool solution_stream_wait_for_permit(pl_solution_stream *st) { if (!st) { return true; } (void)pthread_mutex_lock(&st->mu); while (!st->stop && ((st->pending_solutions > 0) || (!st->streaming && (st->permit == 0)))) { (void)pthread_cond_wait(&st->cv_permit, &st->mu); } const bool ok = !st->stop; (void)pthread_mutex_unlock(&st->mu); return ok; } static void solution_stream_consume_permit_n(pl_solution_stream *st, size_t n) { if (!st) { return; } if (n == 0) { return; } (void)pthread_mutex_lock(&st->mu); if (!st->streaming) { if (st->permit > n) { st->permit -= n; } else { st->permit = 0; } } (void)pthread_mutex_unlock(&st->mu); } static void solution_stream_ack_solutions(pl_solution_stream *st, size_t n) { if (!st) { return; } if (n == 0) { return; } (void)pthread_mutex_lock(&st->mu); if (st->pending_solutions > n) { st->pending_solutions -= n; } else { st->pending_solutions = 0; (void)pthread_cond_broadcast(&st->cv_permit); } (void)pthread_mutex_unlock(&st->mu); } static bool solution_stream_wait_for_input(pl_stream *s) { if (!g_solution_stream || !s || !s->fp) { return true; } const int fd = fileno(s->fp); if (fd < 0 || !isatty(fd)) { return true; } return solution_stream_wait_for_permit(g_solution_stream); } static bool solution_stream_push_owned(pl_solution_stream *st, char *buf, size_t len, bool has_solution) { if (!st || !buf || !len) { free(buf); return st != NULL; } (void)pthread_mutex_lock(&st->mu); while (!st->stop && st->count >= st->cap) { if (solution_stream_grow_locked(st)) { break; } (void)pthread_cond_wait(&st->cv_space, &st->mu); } if (st->stop) { (void)pthread_mutex_unlock(&st->mu); free(buf); return false; } pl_solution_item *slot = &st->items[st->tail]; slot->buf = buf; slot->len = len; slot->has_solution = has_solution; if (has_solution) { st->pending_solutions++; } st->tail = (st->tail + 1) % st->cap; st->count++; (void)pthread_cond_signal(&st->cv_item); (void)pthread_mutex_unlock(&st->mu); return true; } static bool solution_stream_push(pl_solution_stream *st, const char *buf, size_t len, bool has_solution) { if (!st || !buf || !len) { return st != NULL; } char *copy = (char *)malloc(len + 1); if (!copy) { return false; } memcpy(copy, buf, len); copy[len] = '\0'; return solution_stream_push_owned(st, copy, len, has_solution); } static bool solution_stream_emit_solution_segment(pl_solution_stream *st, const char *ptr, size_t n); static bool solution_stream_pop(pl_solution_stream *st, pl_solution_item *out) { if (!st || !out) { return false; } (void)pthread_mutex_lock(&st->mu); while (!st->stop && !st->done && st->count == 0) { (void)pthread_cond_wait(&st->cv_item, &st->mu); } if (st->count == 0) { (void)pthread_mutex_unlock(&st->mu); return false; } pl_solution_item *slot = &st->items[st->head]; *out = *slot; slot->buf = NULL; slot->len = 0; slot->has_solution = false; st->head = (st->head + 1) % st->cap; st->count--; (void)pthread_cond_signal(&st->cv_space); (void)pthread_mutex_unlock(&st->mu); return true; } static bool solution_stream_pop_timeout(pl_solution_stream *st, pl_solution_item *out, int timeout_ms, bool *io_timed_out) { if (!st || !out) { return false; } if (io_timed_out) { *io_timed_out = false; } if (timeout_ms < 0) { return solution_stream_pop(st, out); } struct timespec deadline = {0}; if (clock_gettime(CLOCK_REALTIME, &deadline) != 0) { return solution_stream_pop(st, out); } deadline.tv_sec += timeout_ms / 1000; deadline.tv_nsec += (long)(timeout_ms % 1000) * 1000000L; if (deadline.tv_nsec >= 1000000000L) { deadline.tv_sec += 1; deadline.tv_nsec -= 1000000000L; } (void)pthread_mutex_lock(&st->mu); while (!st->stop && !st->done && st->count == 0) { const int rc = pthread_cond_timedwait(&st->cv_item, &st->mu, &deadline); if (rc == ETIMEDOUT) { if (io_timed_out) { *io_timed_out = true; } (void)pthread_mutex_unlock(&st->mu); return false; } } if (st->count == 0) { (void)pthread_mutex_unlock(&st->mu); return false; } pl_solution_item *slot = &st->items[st->head]; *out = *slot; slot->buf = NULL; slot->len = 0; slot->has_solution = false; st->head = (st->head + 1) % st->cap; st->count--; (void)pthread_cond_signal(&st->cv_space); (void)pthread_mutex_unlock(&st->mu); return true; } static bool solution_stream_is_searching(pl_solution_stream *st) { if (!st) { return false; } bool searching = false; (void)pthread_mutex_lock(&st->mu); searching = (!st->stop && !st->done && (st->count == 0) && (st->pending_solutions == 0) && (st->streaming || (st->permit > 0))); (void)pthread_mutex_unlock(&st->mu); return searching; } static bool solution_stream_emit_solution(pl_solution_stream *st, const char *buf, size_t len) { if (!st) { return true; } if (!buf || !len) { return true; } if (st->pending_io.len) { if (!solution_stream_push(st, st->pending_io.buf, st->pending_io.len, false)) { return false; } sbuf_clear(&st->pending_io); } return solution_stream_emit_solution_segment(st, buf, len); } static bool solution_stream_emit_output(pl_solution_stream *st, const char *buf, size_t len) { if (!st) { return true; } return solution_stream_push(st, buf, len, false); } static bool solution_stream_emit_solution_segment(pl_solution_stream *st, const char *ptr, size_t n) { if (!st || !ptr || !n) { return true; } const char *line = ptr; size_t line_len = 0; for (size_t i = 0; i <= n; i++) { if (i == n || ptr[i] == '\n' || ptr[i] == '\r') { line = ptr + (i - line_len); size_t ln = line_len; // Trim common solution prefixes/newlines. while (ln > 0) { if (ln >= 4 && line[0] == '\n' && line[1] == ';' && line[2] == ' ' && line[3] == ' ') { line += 4; ln -= 4; continue; } if (ln >= 3 && line[0] == ';' && line[1] == ' ' && line[2] == ' ') { line += 3; ln -= 3; continue; } if (ln >= 3 && line[0] == ' ' && line[1] == ' ' && line[2] == ' ') { line += 3; ln -= 3; continue; } if (line[0] == '\n' || line[0] == '\r') { line++; ln--; continue; } break; } if (ln > 0) { if (!solution_stream_push(st, line, ln, true)) { return false; } } line_len = 0; continue; } line_len++; } return true; } static void solution_stream_append_pending(pl_solution_stream *st, const char *buf, size_t len) { if (!st || !buf || !len) { return; } sbuf_append_mem(&st->pending_io, buf, len); } static bool solution_capture_mark(pl_sbuf *out, size_t start) { pl_solution_capture *cap = g_solution_capture; if (!cap || !out || cap->out != out) { return true; } if (start > out->len) { start = out->len; } const size_t end = out->len; if (cap->retain_output) { if (cap->count == cap->cap) { ULO new_cap = cap->cap ? (cap->cap * 2) : 8; pl_solution_span *next = (pl_solution_span *)reallocpool(cap->spans, sizeof(*next) * (size_t)new_cap); if (!next) { return false; } cap->spans = next; cap->cap = new_cap; } cap->spans[cap->count++] = (pl_solution_span){ .start = start, .end = end, }; return true; } if (cap->stream) { bool ok = true; if (start > 0) { ok = solution_stream_emit_output(cap->stream, out->buf, start); } if (ok && end > start) { ok = solution_stream_emit_solution(cap->stream, out->buf + start, end - start); } sbuf_clear(out); cap->count = 0; return ok; } return true; } static inline bool flowlog_capture_user_output_stream(SLO id) { return (id == 1) && (g_stdio_capture != NULL); } static inline void stream_drain_user_output_capture_if_enabled(pl_stream *s, SLO id, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)rt_ctrl; (void)dbg_dat_ptr; if (!flowlog_capture_user_output_stream(id) || !g_stdio_capture_drain_ok) { return; } if (g_stdio_capture && g_stdio_capture->buf && g_stdio_capture->len) { if (s && s->fp) { (void)fwrite(g_stdio_capture->buf, 1, g_stdio_capture->len, s->fp); (void)fflush(s->fp); } sbuf_clear(g_stdio_capture); } } static inline void stream_flush_prompt_output_before_read(pl_stream *in, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)rt_ctrl; if (!in || !in->fp || !g_stdio_capture || !g_stdio_capture_drain_ok) { return; } const int fd = fileno(in->fp); if (fd < 0 || !isatty(fd)) { return; } // ISO-ish: ensure pending output becomes visible before blocking on user input. pl_stream *out = NULL; if (stream_lookup(1, &out, dbg_dat_ptr) && out && out->writable) { stream_drain_user_output_capture_if_enabled(out, 1, rt_ctrl, dbg_dat_ptr); } } static inline void stream_write_mem(pl_stream *s, SLO id, const char *mem, size_t n) { if (!mem || !n) { return; } if (flowlog_capture_user_output_stream(id)) { sbuf_append_mem(g_stdio_capture, mem, n); return; } if (s && s->fp) { (void)fwrite(mem, 1, n, s->fp); } } static inline void stream_write_char(pl_stream *s, SLO id, char c) { if (flowlog_capture_user_output_stream(id)) { sbuf_append_char(g_stdio_capture, c); return; } if (s && s->fp) { (void)fputc((unsigned char)c, s->fp); } } static void sbuf_append_int(pl_sbuf *sb, SLO v) { char tmp[64]; (void)snprintf(tmp, sizeof(tmp), "%ld", (long)v); sbuf_append_cstr(sb, tmp); } static void sbuf_append_bigint(pl_sbuf *sb, const pl_bigint *b) { char *tmp = bigint_to_cstr(b); if (!tmp) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", sb ? sb->dbg_dat_ptr : NULL); return; } sbuf_append_cstr(sb, tmp); free(tmp); } static void float_to_cstr(double v, char *buf, size_t cap) { if (!buf || !cap) { return; } buf[0] = '\0'; (void)snprintf(buf, cap, "%.16g", v); const bool has_dot = strchr(buf, '.') || strchr(buf, 'e') || strchr(buf, 'E'); if (!has_dot) { const size_t n = strlen(buf); if (n + 2 < cap) { buf[n] = '.'; buf[n + 1] = '0'; buf[n + 2] = '\0'; } } } static void sbuf_append_float(pl_sbuf *sb, double v) { char tmp[128]; float_to_cstr(v, tmp, sizeof(tmp)); sbuf_append_cstr(sb, tmp); } static inline bool term_is_nil(const pl_term *t) { return t && t->tag == PL_TERM_ATOM && t->v.atom_name && t->v.atom_name[0] == '[' && t->v.atom_name[1] == ']' && t->v.atom_name[2] == '\0'; } static inline bool term_is_list_pair(const pl_term *t) { return t && t->tag == PL_TERM_STRUCT && t->v.str.arity == 2 && t->v.str.functor && t->v.str.functor[0] == '.' && t->v.str.functor[1] == '\0'; } static inline bool term_is_pstr(const pl_term *t) { return t && t->tag == PL_TERM_PSTR; } static inline bool term_is_pstr_nonempty(const pl_term *t) { return term_is_pstr(t) && t->v.pstr.bytes && t->v.pstr.bytes[0] != 0; } static inline bool term_is_list_like_pair(const pl_term *t) { return term_is_list_pair(t) || term_is_pstr_nonempty(t); } static inline pl_term *term_peel_pstr_empty(pl_term *t) { return (pl_term *)term_peel_pstr_empty_const(t); } static inline bool term_is_compound_like(const pl_term *t) { const pl_term *cur = term_peel_pstr_empty_const(t); return cur && (cur->tag == PL_TERM_STRUCT || term_is_pstr_nonempty(cur)); } static inline bool term_is_callable_like(const pl_term *t) { const pl_term *cur = term_peel_pstr_empty_const(t); return cur && (cur->tag == PL_TERM_ATOM || term_is_compound_like(cur)); } static inline pl_term *pstr_empty_next_tr(pl_term *t, const pl_env *env) { if (!t || t->tag != PL_TERM_PSTR) { return NULL; } const unsigned char *bytes = t->v.pstr.bytes; if (!bytes || bytes[0] != 0) { return NULL; } pl_term *tail = pstr_tail_term_from_nul(bytes); if (!tail) { return NULL; } return deref_term(tail, env); } static pl_term *deref_term_and_peel_pstr_empty(pl_term *t, const pl_env *env) { pl_term *cur = deref_term(t, env); pl_term *slow = cur; pl_term *fast = cur; while (1) { if (!cur || cur->tag != PL_TERM_PSTR) { return cur; } const unsigned char *bytes = cur->v.pstr.bytes; if (!bytes || bytes[0] != 0) { return cur; } pl_term *tail = pstr_tail_term_from_nul(bytes); if (!tail) { return cur; } cur = deref_term(tail, env); slow = pstr_empty_next_tr(slow, env); fast = pstr_empty_next_tr(fast, env); if (fast) { fast = pstr_empty_next_tr(fast, env); } if (slow && fast && slow == fast) { return cur; } } } static inline pl_term *pstr_empty_next_wam(pl_term *t) { if (!t || t->tag != PL_TERM_PSTR) { return NULL; } const unsigned char *bytes = t->v.pstr.bytes; if (!bytes || bytes[0] != 0) { return NULL; } pl_term *tail = pstr_tail_term_from_nul(bytes); if (!tail) { return NULL; } return deref_term_wam(tail); } static pl_term *deref_term_wam_and_peel_pstr_empty(pl_term *t) { pl_term *cur = deref_term_wam(t); pl_term *slow = cur; pl_term *fast = cur; while (1) { if (!cur || cur->tag != PL_TERM_PSTR) { return cur; } const unsigned char *bytes = cur->v.pstr.bytes; if (!bytes || bytes[0] != 0) { return cur; } pl_term *tail = pstr_tail_term_from_nul(bytes); if (!tail) { return cur; } cur = deref_term_wam(tail); slow = pstr_empty_next_wam(slow); fast = pstr_empty_next_wam(fast); if (fast) { fast = pstr_empty_next_wam(fast); } if (slow && fast && slow == fast) { return cur; } } } static bool pstr_uncons_rt(const pl_term *t, pl_term **out_head, pl_term **out_tail, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!t || t->tag != PL_TERM_PSTR || !t->v.pstr.bytes || t->v.pstr.bytes[0] == 0 || !out_head || !out_tail) { return false; } uint32_t ch = 0; const size_t used = pstr_decode_one(t->v.pstr.bytes, &ch); if (!used) { return false; } *out_head = make_char_atom_rt(dbg_dat_ptr, ch); if (t->v.pstr.bytes[used] != 0) { *out_tail = make_pstr_slice_bytes_rt(rt_ctrl, dbg_dat_ptr, t, (ULO)used); } else { pl_term *tail = pstr_tail_term_from_nul(t->v.pstr.bytes + used); *out_tail = tail ? tail : make_nil_rt(dbg_dat_ptr); } return true; } static bool term_list_like_uncons_rt(pl_term *t, pl_term **out_head, pl_term **out_tail, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!t || !out_head || !out_tail) { return false; } t = term_peel_pstr_empty(t); if (term_is_list_pair(t)) { *out_head = t->v.str.args[0]; *out_tail = t->v.str.args[1]; return true; } if (term_is_pstr_nonempty(t)) { return pstr_uncons_rt(t, out_head, out_tail, rt_ctrl, dbg_dat_ptr); } return false; } typedef struct { const pl_term *slow; const pl_term *fast; bool active; } pl_list_cycle_guard; typedef struct { bool has_cycle; ULO prefix_len; ULO cycle_len; } pl_list_cycle_info; static inline bool list_cycle_node_equal(const pl_term *a, const pl_term *b) { if (!a || !b) { return false; } if (a->tag == PL_TERM_PSTR && b->tag == PL_TERM_PSTR) { return a->v.pstr.bytes == b->v.pstr.bytes; } return a == b; } static const pl_term *list_like_next_tr(const pl_term *cur, const pl_env *env) { if (!cur) { return NULL; } cur = (const pl_term *)deref_term((pl_term *)cur, env); cur = term_peel_pstr_empty_const(cur); if (!cur || term_is_nil(cur)) { return NULL; } const pl_term *h = NULL; const pl_term *tail = NULL; pl_term head_tmp = {0}; pl_term tail_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; if (!term_list_like_uncons_view(cur, &h, &tail, &head_tmp, head_ch, &tail_tmp)) { return NULL; } return tail; } static const pl_program_argv_src *flowlog_program_find_src_argv(const pl_program *prog, const CHR *src_name) { if (!prog || !src_name || !*src_name) { return NULL; } for (ULO i = prog->flag_argv_src_count; i > 0; i--) { const pl_program_argv_src *e = &prog->flag_argv_srcs[i - 1]; if (e->src_name && !strcmp(e->src_name, src_name)) { return e; } } return NULL; } static pl_term *flowlog_build_argv_term(const pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr) { const CHR *const *argv_items = NULL; ULO argv_count = 0; if (prog) { argv_items = (const CHR *const *)prog->flag_argv; argv_count = prog->flag_argv_count; const pl_clause *ctx_clause = g_argv_clause ? g_argv_clause : g_trace_clause; const CHR *src_name = (ctx_clause && ctx_clause->src_name && *ctx_clause->src_name) ? ctx_clause->src_name : NULL; if (src_name) { const pl_program_argv_src *e = flowlog_program_find_src_argv(prog, src_name); if (e) { argv_items = (const CHR *const *)e->argv; argv_count = e->argc; } } } if (!argv_items || !argv_count) { return make_nil_rt(dbg_dat_ptr); } pl_term **elems = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * argv_count, dbg_dat_ptr); for (ULO i = 0; i < argv_count; i++) { const CHR *s = (argv_items[i] && *argv_items[i]) ? argv_items[i] : ""; size_t len = strlen(s); if (len > (size_t)ULONG_MAX) { len = (size_t)ULONG_MAX; } elems[i] = make_pstr_rt(rt_ctrl, dbg_dat_ptr, (const unsigned char *)s, (ULO)len, make_nil_rt(dbg_dat_ptr)); } return build_list_rt(rt_ctrl, dbg_dat_ptr, elems, argv_count); } static const pl_term *list_like_next_wam(const pl_term *cur) { if (!cur) { return NULL; } cur = (const pl_term *)deref_term_wam((pl_term *)cur); cur = term_peel_pstr_empty_const(cur); if (!cur || term_is_nil(cur)) { return NULL; } const pl_term *h = NULL; const pl_term *tail = NULL; pl_term head_tmp = {0}; pl_term tail_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; if (!term_list_like_uncons_view(cur, &h, &tail, &head_tmp, head_ch, &tail_tmp)) { return NULL; } return tail; } static inline void list_cycle_guard_init(pl_list_cycle_guard *g, const pl_term *start) { if (!g) { return; } g->slow = start; g->fast = start; g->active = (start != NULL); } static inline bool list_cycle_guard_step_tr_always(pl_list_cycle_guard *g, const pl_env *env) { if (!g || !g->active) { return false; } const pl_term *slow = list_like_next_tr(g->slow, env); const pl_term *fast = list_like_next_tr(g->fast, env); if (fast) { fast = list_like_next_tr(fast, env); } g->slow = slow; g->fast = fast; if (!slow || !fast) { g->active = false; return false; } return list_cycle_node_equal(slow, fast); } static inline bool list_cycle_guard_step_tr(pl_list_cycle_guard *g, const pl_env *env) { const bool hit = list_cycle_guard_step_tr_always(g, env); if (!hit) { return false; } if (!g_unify_occurs_check) { g->active = false; return false; } return true; } static inline bool list_cycle_guard_step_wam_always(pl_list_cycle_guard *g) { if (!g || !g->active) { return false; } const pl_term *slow = list_like_next_wam(g->slow); const pl_term *fast = list_like_next_wam(g->fast); if (fast) { fast = list_like_next_wam(fast); } g->slow = slow; g->fast = fast; if (!slow || !fast) { g->active = false; return false; } return list_cycle_node_equal(slow, fast); } static inline bool list_cycle_guard_step_wam(pl_list_cycle_guard *g) { const bool hit = list_cycle_guard_step_wam_always(g); if (!hit) { return false; } if (!g_unify_occurs_check) { g->active = false; return false; } return true; } static const pl_term *list_pair_next_tr(const pl_term *cur, const pl_env *env) { if (!cur) { return NULL; } cur = (const pl_term *)deref_term((pl_term *)cur, env); if (!cur || !term_is_list_pair(cur)) { return NULL; } return (const pl_term *)deref_term(cur->v.str.args[1], env); } static const pl_term *list_pair_next_wam(const pl_term *cur) { if (!cur) { return NULL; } cur = (const pl_term *)deref_term_wam((pl_term *)cur); if (!cur || !term_is_list_pair(cur)) { return NULL; } return (const pl_term *)deref_term_wam(cur->v.str.args[1]); } static bool list_pair_cycle_info_tr(const pl_term *list0, const pl_env *env, pl_list_cycle_info *out) { if (!out) { return false; } *out = (pl_list_cycle_info){0}; const pl_term *slow = (const pl_term *)deref_term((pl_term *)list0, env); if (!slow || !term_is_list_pair(slow)) { return false; } const pl_term *fast = slow; while (1) { slow = list_pair_next_tr(slow, env); if (!slow) { return false; } fast = list_pair_next_tr(fast, env); if (!fast) { return false; } fast = list_pair_next_tr(fast, env); if (!fast) { return false; } if (slow == fast) { break; } } const pl_term *entry = (const pl_term *)deref_term((pl_term *)list0, env); ULO prefix_len = 0; while (entry && slow && (entry != slow)) { entry = list_pair_next_tr(entry, env); slow = list_pair_next_tr(slow, env); if (!entry || !slow) { return false; } prefix_len++; } if (!entry) { return false; } ULO cycle_len = 1; const pl_term *cur = list_pair_next_tr(entry, env); while (cur && cur != entry) { cur = list_pair_next_tr(cur, env); cycle_len++; } if (!cur) { return false; } out->has_cycle = true; out->prefix_len = prefix_len; out->cycle_len = cycle_len; return true; } static bool list_pair_cycle_info_wam(const pl_term *list0, pl_list_cycle_info *out) { if (!out) { return false; } *out = (pl_list_cycle_info){0}; const pl_term *slow = (const pl_term *)deref_term_wam((pl_term *)list0); if (!slow || !term_is_list_pair(slow)) { return false; } const pl_term *fast = slow; while (1) { slow = list_pair_next_wam(slow); if (!slow) { return false; } fast = list_pair_next_wam(fast); if (!fast) { return false; } fast = list_pair_next_wam(fast); if (!fast) { return false; } if (slow == fast) { break; } } const pl_term *entry = (const pl_term *)deref_term_wam((pl_term *)list0); ULO prefix_len = 0; while (entry && slow && (entry != slow)) { entry = list_pair_next_wam(entry); slow = list_pair_next_wam(slow); if (!entry || !slow) { return false; } prefix_len++; } if (!entry) { return false; } ULO cycle_len = 1; const pl_term *cur = list_pair_next_wam(entry); while (cur && cur != entry) { cur = list_pair_next_wam(cur); cycle_len++; } if (!cur) { return false; } out->has_cycle = true; out->prefix_len = prefix_len; out->cycle_len = cycle_len; return true; } static inline ULO term_compound_arity(const pl_term *t) { const pl_term *cur = term_peel_pstr_empty_const(t); if (!cur) { return 0; } if (cur->tag == PL_TERM_STRUCT) { return cur->v.str.arity; } if (term_is_pstr_nonempty(cur)) { return 2; } return 0; } static bool term_compound_arg_rt(pl_term *t, SLO idx, pl_term **out_val, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out_val || idx <= 0) { return false; } t = term_peel_pstr_empty(t); if (!t) { return false; } if (t->tag == PL_TERM_STRUCT) { const ULO arity = t->v.str.arity; if ((ULO)idx > arity) { return false; } *out_val = t->v.str.args[(ULO)idx - 1]; return true; } if (term_is_pstr_nonempty(t)) { if (idx > 2) { return false; } pl_term *h = NULL; pl_term *tail = NULL; if (!pstr_uncons_rt(t, &h, &tail, rt_ctrl, dbg_dat_ptr)) { return false; } *out_val = (idx == 1) ? h : tail; return true; } return false; } static bool term_functor_arity_rt(pl_term *t, pl_term **out_name, SLO *out_arity, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!t || !out_name || !out_arity) { return false; } t = term_peel_pstr_empty(t); if (!t) { return false; } if (t->tag == PL_TERM_STRUCT) { *out_name = make_atom_rt(rt_ctrl, dbg_dat_ptr, t->v.str.functor); *out_arity = (SLO)t->v.str.arity; return true; } if (term_is_pstr_nonempty(t)) { *out_name = make_char_atom_rt(dbg_dat_ptr, (uint32_t)'.'); *out_arity = 2; return true; } *out_name = t; *out_arity = 0; return true; } static bool term_is_syntactic_ground(const pl_term *t, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return true; } if (t->tag == PL_TERM_VAR) { return false; } if (t->tag == PL_TERM_PSTR) { pl_term *tail = pstr_tail_term(t); return !tail ? true : term_is_syntactic_ground(tail, depth + 1); } if (t->tag != PL_TERM_STRUCT) { return true; } for (ULO i = 0; i < t->v.str.arity; i++) { if (!term_is_syntactic_ground(t->v.str.args[i], depth + 1)) { return false; } } return true; } // Conservative WAM-lite compatibility scan. // // The WAM-lite execution path is still growing. Rather than silently returning // `false` for programs that rely on unsupported features, we conservatively // route such programs through the interpreter engine until WAM-lite coverage // expands. static bool term_requires_interp_for_wam(const pl_term *t, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return false; } if (t->tag == PL_TERM_STRUCT && t->v.str.functor && t->v.str.args) { for (ULO i = 0; i < t->v.str.arity; i++) { if (term_requires_interp_for_wam(t->v.str.args[i], depth + 1)) { return true; } } } return false; } static bool clause_requires_interp_for_wam(const pl_clause *cl) { if (!cl || !cl->body_count || !cl->body) { return false; } for (ULO i = 1; i <= cl->body_count; i++) { if (term_requires_interp_for_wam(cl->body[i], 0)) { return true; } } return false; } static bool program_requires_interp_for_wam(const pl_program *prog) { if (!prog || !prog->clause_count || !prog->clauses) { return false; } for (ULO i = 1; i <= prog->clause_count; i++) { if (clause_requires_interp_for_wam(prog->clauses[i])) { return true; } } return false; } static bool query_requires_interp_for_wam(const pl_query *q) { if (!q || !q->goal_count || !q->goals) { return false; } for (ULO i = 1; i <= q->goal_count; i++) { if (term_requires_interp_for_wam(q->goals[i], 0)) { return true; } } return false; } typedef struct { pl_term **items; ULO count; ULO cap; } pl_term_vec; static void term_vec_init(pl_term_vec *v) { memset(v, 0, sizeof(*v)); } static void term_vec_free(pl_term_vec *v) { free(v->items); memset(v, 0, sizeof(*v)); } static void term_vec_push(pl_term_vec *v, const ULO *dbg_dat_ptr, pl_term *t) { if (v->count == v->cap) { ULO new_cap = v->cap ? (v->cap * 2) : 16; pl_term **new_items = (pl_term **)realloc(v->items, sizeof(pl_term *) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } v->items = new_items; v->cap = new_cap; } v->items[v->count++] = t; } typedef struct { pl_term *key; pl_term_vec templates; } pl_solution_group; typedef struct { pl_solution_group *items; ULO count; ULO cap; } pl_solution_group_vec; static void group_vec_init(pl_solution_group_vec *v) { memset(v, 0, sizeof(*v)); } static void group_vec_free(pl_solution_group_vec *v) { if (v && v->items) { for (ULO i = 0; i < v->count; i++) { term_vec_free(&v->items[i].templates); } } free(v->items); memset(v, 0, sizeof(*v)); } static pl_solution_group *group_vec_push(pl_solution_group_vec *v, const ULO *dbg_dat_ptr) { if (v->count == v->cap) { ULO new_cap = v->cap ? (v->cap * 2) : 16; pl_solution_group *new_items = (pl_solution_group *)realloc(v->items, sizeof(pl_solution_group) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } v->items = new_items; v->cap = new_cap; } pl_solution_group *g = &v->items[v->count++]; memset(g, 0, sizeof(*g)); term_vec_init(&g->templates); return g; } static FLOWLOG_TLS const pl_env *g_group_qsort_env = NULL; static FLOWLOG_TLS const ULO *g_group_qsort_dbg_dat_ptr = NULL; static int qsort_solution_group_cmp(const void *pa, const void *pb) { const pl_solution_group *a = (const pl_solution_group *)pa; const pl_solution_group *b = (const pl_solution_group *)pb; return compare_std_terms_env(a->key, b->key, g_group_qsort_env, g_group_qsort_dbg_dat_ptr); } static FLOWLOG_TLS const ULO *g_group_qsort_wam_dbg_dat_ptr = NULL; static int qsort_solution_group_cmp_wam(const void *pa, const void *pb) { const pl_solution_group *a = (const pl_solution_group *)pa; const pl_solution_group *b = (const pl_solution_group *)pb; return compare_std_terms_wam(a->key, b->key, g_group_qsort_wam_dbg_dat_ptr); } static bool list_to_vec(pl_term *list, const pl_env *env, pl_term_vec *out, const ULO *dbg_dat_ptr) { term_vec_init(out); pl_term *cur = deref_term(list, env); pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { if (term_is_nil(cur)) { return true; } if (cur && cur->tag == PL_TERM_PSTR) { if (!cur->v.pstr.bytes) { term_vec_free(out); return false; } const unsigned char *p = cur->v.pstr.bytes; while (*p) { uint32_t cp = 0; const size_t used = pstr_decode_one(p, &cp); if (!used) { break; } term_vec_push(out, dbg_dat_ptr, make_char_atom_rt(dbg_dat_ptr, cp)); p += used; } pl_term *tail = pstr_tail_term_from_nul(p); if (!tail) { term_vec_free(out); return false; } cur = deref_term(tail, env); if (list_cycle_guard_step_tr(&cg, env)) { term_vec_free(out); return false; } continue; } if (!term_is_list_pair(cur)) { term_vec_free(out); return false; } term_vec_push(out, dbg_dat_ptr, cur->v.str.args[0]); cur = deref_term(cur->v.str.args[1], env); if (list_cycle_guard_step_tr(&cg, env)) { term_vec_free(out); return false; } } term_vec_free(out); return false; } typedef enum { PL_LIST_STATUS_OK = 0, PL_LIST_STATUS_INSTANTIATION, PL_LIST_STATUS_TYPE_ERROR, } pl_list_status; static pl_list_status list_to_vec_iso(pl_term *list, const pl_env *env, pl_term_vec *out, const ULO *dbg_dat_ptr) { term_vec_init(out); pl_term *cur = deref_term(list, env); pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { if (!cur) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } if (term_is_nil(cur)) { return PL_LIST_STATUS_OK; } if (cur->tag == PL_TERM_VAR) { term_vec_free(out); return PL_LIST_STATUS_INSTANTIATION; } if (cur->tag == PL_TERM_PSTR) { if (!cur->v.pstr.bytes) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } const unsigned char *p = cur->v.pstr.bytes; while (*p) { uint32_t cp = 0; const size_t used = pstr_decode_one(p, &cp); if (!used) { break; } term_vec_push(out, dbg_dat_ptr, make_char_atom_rt(dbg_dat_ptr, cp)); p += used; } pl_term *tail = pstr_tail_term_from_nul(p); if (!tail) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } cur = deref_term(tail, env); if (list_cycle_guard_step_tr(&cg, env)) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } continue; } if (!term_is_list_pair(cur)) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } term_vec_push(out, dbg_dat_ptr, cur->v.str.args[0]); cur = deref_term(cur->v.str.args[1], env); if (list_cycle_guard_step_tr(&cg, env)) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } } term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } static pl_list_status list_to_vec_iso_wam(pl_term *list, pl_term_vec *out, const ULO *dbg_dat_ptr) { term_vec_init(out); pl_term *cur = deref_term_wam(list); pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { if (!cur) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } if (term_is_nil(cur)) { return PL_LIST_STATUS_OK; } if (cur->tag == PL_TERM_VAR) { term_vec_free(out); return PL_LIST_STATUS_INSTANTIATION; } if (cur->tag == PL_TERM_PSTR) { if (!cur->v.pstr.bytes) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } const unsigned char *p = cur->v.pstr.bytes; while (*p) { uint32_t cp = 0; const size_t used = pstr_decode_one(p, &cp); if (!used) { break; } term_vec_push(out, dbg_dat_ptr, make_char_atom_rt(dbg_dat_ptr, cp)); p += used; } pl_term *tail = pstr_tail_term_from_nul(p); if (!tail) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } cur = deref_term_wam(tail); if (list_cycle_guard_step_wam(&cg)) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } continue; } if (!term_is_list_pair(cur)) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } term_vec_push(out, dbg_dat_ptr, cur->v.str.args[0]); cur = deref_term_wam(cur->v.str.args[1]); if (list_cycle_guard_step_wam(&cg)) { term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } } term_vec_free(out); return PL_LIST_STATUS_TYPE_ERROR; } static bool atom_codepoint(const pl_term *t, uint32_t *out_cp) { if (!t || (t->tag != PL_TERM_ATOM) || !t->v.atom_name || !out_cp) { return false; } const unsigned char *name = (const unsigned char *)t->v.atom_name; if (!name[0]) { return false; } if (name[1] == 0) { *out_cp = (uint32_t)name[0]; return true; } size_t avail = 0; while (avail < PL_UTF8_MAX_BYTES && name[avail] != 0) { avail++; } if (!avail || name[avail] != 0) { return false; } uint32_t cp = 0; const size_t used = utf8_decode_one_lenient((const unsigned char *)t->v.atom_name, avail, &cp); if (!used || name[used] != 0) { return false; } *out_cp = cp; return true; } static bool atom_is_char(const pl_term *t) { uint32_t cp = 0; return atom_codepoint(t, &cp); } typedef struct { bool is_float; bool is_big; SLO ival; double fval; pl_bigint *big; } pl_parsed_number; static bool parse_char_escape_1(const CHR esc, uint32_t *out) { if (!out) { return false; } switch (esc) { case 'a': *out = (uint32_t)'\a'; return true; case 'n': *out = (uint32_t)'\n'; return true; case 't': *out = (uint32_t)'\t'; return true; case 'r': *out = (uint32_t)'\r'; return true; case 'v': *out = (uint32_t)'\v'; return true; case 'b': *out = (uint32_t)'\b'; return true; case 'f': *out = (uint32_t)'\f'; return true; case 'e': *out = (uint32_t)0x1B; return true; case '\\': *out = (uint32_t)'\\'; return true; case '\'': *out = (uint32_t)'\''; return true; case '"': *out = (uint32_t)'"'; return true; default: return false; } } static bool parse_number_iso_cstr(const CHR *s, pl_parsed_number *out, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!s || !out) { return false; } out->is_float = false; out->is_big = false; out->ival = 0; out->fval = 0.0; out->big = NULL; const CHR *p = s; while (*p && isspace((unsigned char)*p)) { p++; } if (!*p) { return false; } const CHR *start = p; int sign = 1; if (*p == '+' || *p == '-') { if (*p == '-') { sign = -1; } p++; } // ISO character code integer: 0' or 0'\ if (p[0] == '0' && p[1] == '\'') { p += 2; if (!*p) { return false; } uint32_t ch = 0; if (*p == '\\') { p++; if (!*p) { return false; } if (*p == 'x' || *p == 'X') { p++; // consume 'x' uint32_t v = 0; int digits = 0; while (*p) { if (*p == '\\') { p++; // consume terminator break; } const int hv = hex_digit_val((unsigned char)*p); if (hv < 0) { digits = 0; break; } v = (v * 16u) + (uint32_t)hv; digits++; p++; } if (digits <= 0 || !unicode_codepoint_valid(v)) { return false; } ch = v; } else if (*p >= '0' && *p <= '7') { uint32_t v = (uint32_t)(*p - '0'); int digits = 1; p++; // consume first digit while (*p) { if (*p == '\\') { p++; // consume terminator break; } if (*p < '0' || *p > '7') { digits = 0; break; } v = (v * 8u) + (uint32_t)(*p - '0'); digits++; p++; } if (digits <= 0 || !unicode_codepoint_valid(v)) { return false; } ch = v; } else { if (!parse_char_escape_1(*p, &ch)) { return false; } p++; } } else { const size_t remain = strlen(p); const size_t used = utf8_decode_one_lenient((const unsigned char *)p, remain, &ch); if (!used || !unicode_codepoint_valid(ch)) { return false; } p += used; } if (*p != '\0') { return false; } out->is_float = false; out->ival = (SLO)(sign * (SLO)ch); return true; } const bool want_float = strchr(start, '.') || strchr(start, 'e') || strchr(start, 'E'); if (want_float) { char *end = NULL; errno = 0; const double v = strtod(start, &end); if (errno || !end || (end == (char *)start) || (*end != '\0')) { return false; } out->is_float = true; out->fval = v; return true; } if (!*p) { return false; } int base = 10; const CHR *digits = p; if (digits[0] == '0') { if (digits[1] == 'x' || digits[1] == 'X') { base = 16; digits += 2; } else if (digits[1] != '\0') { base = 8; digits += 1; } } size_t dlen = strlen(digits); if (!dlen) { out->is_float = false; out->ival = 0; return true; } const uint64_t limit = (sign < 0) ? ((uint64_t)LONG_MAX + 1u) : (uint64_t)LONG_MAX; uint64_t mag = 0; bool overflow = false; for (size_t i = 0; i < dlen; i++) { const int dv = bigint_digit_val((unsigned char)digits[i]); if (dv < 0 || dv >= base) { return false; } if (mag > ((limit - (uint64_t)dv) / (uint64_t)base)) { overflow = true; break; } mag = mag * (uint64_t)base + (uint64_t)dv; } if (!overflow) { out->is_float = false; if (sign < 0) { if (mag == (uint64_t)LONG_MAX + 1u) { out->ival = LONG_MIN; } else { out->ival = -(SLO)mag; } } else { out->ival = (SLO)mag; } return true; } pl_bigint *big = bigint_from_cstr_base(digits, dlen, base, sign, rt_ctrl, dbg_dat_ptr); if (!big) { return false; } out->is_float = false; out->is_big = true; out->big = big; return true; } static bool atom_name_is_bare(const CHR *s) { if (!s || !*s) { return false; } if (!islower((unsigned char)s[0])) { return false; } for (const unsigned char *p = (const unsigned char *)s + 1; *p; p++) { if (!is_id_continue(*p)) { return false; } } return true; } static bool atom_name_is_graphic(const CHR *s) { if (!s || !*s) { return false; } if ((s[0] == '!') && (s[1] == '\0')) { // ISO cut token is a solo-character atom, but it prints as a graphic token. return true; } if (s[0] == '{' && s[1] == '}' && s[2] == '\0') { // Trealla/ISO treat '{}' as a graphic token atom. return true; } if ((s[0] == '.') && !s[1]) { // Avoid printing a bare '.' which is ambiguous with a full stop. return false; } for (const unsigned char *p = (const unsigned char *)s; *p; p++) { if (!is_symbol_atom_char(*p)) { return false; } } return true; } static void sbuf_append_quoted_atom(pl_sbuf *sb, const CHR *s) { sbuf_append_char(sb, '\''); for (const CHR *p = s; p && *p; p++) { if (*p == '\'') { sbuf_append_cstr(sb, "''"); } else { sbuf_append_char(sb, *p); } } sbuf_append_char(sb, '\''); } static void sbuf_append_quoted_string_bytes(pl_sbuf *sb, const unsigned char *bytes, ULO len) { sbuf_append_char(sb, '"'); for (ULO i = 0; bytes && (i < len); i++) { const unsigned char c = bytes[i]; switch (c) { case '\\': sbuf_append_cstr(sb, "\\\\"); break; case '"': sbuf_append_cstr(sb, "\\\""); break; case '\n': sbuf_append_cstr(sb, "\\n"); break; case '\r': sbuf_append_cstr(sb, "\\r"); break; case '\t': sbuf_append_cstr(sb, "\\t"); break; case '\b': sbuf_append_cstr(sb, "\\b"); break; case '\f': sbuf_append_cstr(sb, "\\f"); break; default: if ((c < 0x20u) || (c == 0x7Fu)) { char tmp[8] = {0}; (void)snprintf(tmp, sizeof(tmp), "\\x%02X\\", (unsigned)c); sbuf_append_cstr(sb, tmp); } else { sbuf_append_mem(sb, (const char *)&c, 1); } break; } } sbuf_append_char(sb, '"'); } static bool sbuf_try_append_pstr_string_env( pl_sbuf *sb, const pl_term *t, const pl_env *env, const ULO *dbg_dat_ptr) { const unsigned char *s = NULL; ULO slen = 0; unsigned char *owned = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_env((pl_term *)t, env, &s, &slen, &owned, dbg_dat_ptr); if (!pstr_cstr_status_ok(pst)) { return false; } sbuf_append_quoted_string_bytes(sb, s, slen); free(owned); return true; } static bool sbuf_try_append_pstr_string_wam(pl_sbuf *sb, const pl_term *t, const ULO *dbg_dat_ptr) { const unsigned char *s = NULL; ULO slen = 0; unsigned char *owned = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_wam((pl_term *)t, &s, &slen, &owned, dbg_dat_ptr); if (!pstr_cstr_status_ok(pst)) { return false; } sbuf_append_quoted_string_bytes(sb, s, slen); free(owned); return true; } static void sbuf_append_atom(pl_sbuf *sb, const CHR *s) { if (!s || !*s) { sbuf_append_cstr(sb, "''"); return; } if (atom_name_is_bare(s) || atom_name_is_graphic(s)) { sbuf_append_cstr(sb, s); return; } sbuf_append_quoted_atom(sb, s); } static void sbuf_append_numbervar_name(pl_sbuf *sb, SLO n) { if (!sb || (n < 0)) { return; } const SLO letter = n % 26; const SLO suffix = n / 26; sbuf_append_char(sb, (CHR)('A' + (CHR)letter)); if (suffix > 0) { sbuf_append_int(sb, suffix); } } /* --- SUBSECTION 17.2: Term Printer (Interp) ------------------------------ */ // Interpreter term printer. // term_to_sbuf() renders terms to pl_sbuf with list/pstr awareness and operator precedence. static void term_to_sbuf_tr(const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth); static void term_to_sbuf_list_tr(const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (sbuf_try_append_pstr_string_env(sb, t, env, dbg_dat_ptr)) { return; } sbuf_append_char(sb, '['); const ULO st_save = st ? st->count : 0; const pl_term *cur = t; bool first = true; pl_term tail_tmp = {0}; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); bool cycle = false; while (1) { if (!cur) { sbuf_append_cstr(sb, ""); break; } if (cur->tag == PL_TERM_VAR) { pl_term *b = env_binding_for_var(env, cur); if (!b) { sbuf_append_char(sb, '|'); sbuf_append_cstr(sb, cur->v.var.var_name); break; } pl_var_key k = {.scope = cur->v.var.scope, .var_id = cur->v.var.var_id}; if (st && var_stack_contains(st, k)) { sbuf_append_char(sb, '|'); sbuf_append_cstr(sb, cur->v.var.var_name); break; } if (st) { var_stack_push(st, dbg_dat_ptr, k); } cur = (const pl_term *)deref_term(b, env); continue; } cur = (const pl_term *)deref_term((pl_term *)cur, env); cur = term_peel_pstr_empty_const(cur); if (cur && cur->tag == PL_TERM_VAR) { continue; } if (term_is_nil(cur)) { break; } const pl_term *h = NULL; const pl_term *tail = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; if (!term_list_like_uncons_view(cur, &h, &tail, &head_tmp, head_ch, &tail_tmp)) { sbuf_append_char(sb, '|'); term_to_sbuf_tr(cur, env, sb, st, dbg_dat_ptr, depth + 1); break; } if (!first) { sbuf_append_char(sb, ','); } term_to_sbuf_tr(h, env, sb, st, dbg_dat_ptr, depth + 1); first = false; cur = tail; if (list_cycle_guard_step_tr_always(&cg, env)) { cycle = true; break; } } if (cycle) { if (!first) { sbuf_append_char(sb, '|'); } sbuf_append_cstr(sb, "..."); } sbuf_append_char(sb, ']'); if (st) { st->count = st_save; } } static void term_to_sbuf_tr(const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t) { sbuf_append_cstr(sb, ""); return; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { sbuf_append_cstr(sb, "..."); return; } if (t->tag == PL_TERM_VAR) { pl_term *b = env_binding_for_var(env, t); if (!b) { sbuf_append_cstr(sb, t->v.var.var_name); return; } pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; if (st && var_stack_contains(st, k)) { sbuf_append_cstr(sb, t->v.var.var_name); return; } if (st) { var_stack_push(st, dbg_dat_ptr, k); } term_to_sbuf_tr(b, env, sb, st, dbg_dat_ptr, depth + 1); if (st) { var_stack_pop(st); } return; } t = (const pl_term *)deref_term((pl_term *)t, env); t = term_peel_pstr_empty_const(t); if (term_is_nil(t)) { sbuf_append_cstr(sb, "[]"); return; } if (term_is_list_like_pair(t)) { term_to_sbuf_list_tr(t, env, sb, st, dbg_dat_ptr, depth); return; } switch (t->tag) { case PL_TERM_ATOM: sbuf_append_atom(sb, t->v.atom_name); return; case PL_TERM_INT: sbuf_append_int(sb, t->v.int_value); return; case PL_TERM_BIGINT: sbuf_append_bigint(sb, t->v.bigint); return; case PL_TERM_FLOAT: sbuf_append_float(sb, t->v.float_value); return; case PL_TERM_VAR: sbuf_append_cstr(sb, t->v.var.var_name); return; case PL_TERM_STRUCT: { if ((t->v.str.arity == 1) && !strcmp(t->v.str.functor, "$VAR")) { pl_term *a = deref_term(t->v.str.args[0], env); if (a && term_is_integer(a)) { SLO v = 0; if (a->tag == PL_TERM_INT) { v = a->v.int_value; } else if (!bigint_fits_slo(a->v.bigint, &v)) { v = -1; } if (v >= 0) { sbuf_append_numbervar_name(sb, v); return; } } } sbuf_append_atom(sb, t->v.str.functor); sbuf_append_char(sb, '('); for (ULO i = 0; i < t->v.str.arity; i++) { if (i) { sbuf_append_char(sb, ','); } term_to_sbuf_tr(t->v.str.args[i], env, sb, st, dbg_dat_ptr, depth + 1); } sbuf_append_char(sb, ')'); return; } default: sbuf_append_cstr(sb, ""); return; } } static void term_to_sbuf(const pl_term *t, const pl_env *env, pl_sbuf *sb, const ULO *dbg_dat_ptr) { pl_var_stack st; var_stack_init(&st); term_to_sbuf_tr(t, env, sb, &st, dbg_dat_ptr, 0); var_stack_free(&st); } /* --- SUBSECTION 17.3: Term Printer (WAM) --------------------------------- */ // WAM term printer and environment formatting. // term_to_sbuf_tr_wam()/term_to_sbuf_list_tr_wam() print terms; env_to_sbuf_wam() dumps variable bindings. static void term_to_sbuf_tr_wam(const pl_term *t, pl_sbuf *sb, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth); static void term_to_sbuf_list_tr_wam(const pl_term *t, pl_sbuf *sb, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (sbuf_try_append_pstr_string_wam(sb, t, dbg_dat_ptr)) { return; } sbuf_append_char(sb, '['); const ULO st_save = st ? st->count : 0; const pl_term *cur = t; bool first = true; pl_term tail_tmp = {0}; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); bool cycle = false; while (1) { if (!cur) { sbuf_append_cstr(sb, ""); break; } cur = (const pl_term *)deref_term_wam((pl_term *)cur); if (!cur) { sbuf_append_cstr(sb, ""); break; } if (cur->tag == PL_TERM_VAR) { pl_wam_cell *cell = wam_cell_for_var(cur); pl_term *b = cell ? cell->value : NULL; if (!b) { sbuf_append_char(sb, '|'); sbuf_append_cstr(sb, cur->v.var.var_name); break; } pl_var_key k = {.scope = cur->v.var.scope, .var_id = cur->v.var.var_id}; if (st && var_stack_contains(st, k)) { sbuf_append_char(sb, '|'); sbuf_append_cstr(sb, cur->v.var.var_name); break; } if (st) { var_stack_push(st, dbg_dat_ptr, k); } cur = (const pl_term *)deref_term_wam(b); continue; } cur = term_peel_pstr_empty_const(cur); if (cur && cur->tag == PL_TERM_VAR) { continue; } if (term_is_nil(cur)) { break; } const pl_term *h = NULL; const pl_term *tail = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; if (!term_list_like_uncons_view(cur, &h, &tail, &head_tmp, head_ch, &tail_tmp)) { sbuf_append_char(sb, '|'); term_to_sbuf_tr_wam(cur, sb, st, dbg_dat_ptr, depth + 1); break; } if (!first) { sbuf_append_char(sb, ','); } term_to_sbuf_tr_wam(h, sb, st, dbg_dat_ptr, depth + 1); first = false; cur = tail; if (list_cycle_guard_step_wam(&cg)) { cycle = true; break; } } if (cycle) { if (!first) { sbuf_append_char(sb, '|'); } sbuf_append_cstr(sb, "..."); } sbuf_append_char(sb, ']'); if (st) { st->count = st_save; } } static void term_to_sbuf_tr_wam(const pl_term *t, pl_sbuf *sb, pl_var_stack *st, const ULO *dbg_dat_ptr, ULO depth) { if (!t) { sbuf_append_cstr(sb, ""); return; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { sbuf_append_cstr(sb, "..."); return; } t = (const pl_term *)deref_term_wam((pl_term *)t); if (!t) { sbuf_append_cstr(sb, ""); return; } t = term_peel_pstr_empty_const(t); t = (const pl_term *)deref_term_wam((pl_term *)t); if (!t) { sbuf_append_cstr(sb, ""); return; } if (t->tag == PL_TERM_VAR) { pl_wam_cell *cell = wam_cell_for_var(t); pl_term *b = cell ? cell->value : NULL; if (!b) { sbuf_append_cstr(sb, t->v.var.var_name); return; } pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; if (st && var_stack_contains(st, k)) { sbuf_append_cstr(sb, t->v.var.var_name); return; } if (st) { var_stack_push(st, dbg_dat_ptr, k); } term_to_sbuf_tr_wam(b, sb, st, dbg_dat_ptr, depth + 1); if (st) { var_stack_pop(st); } return; } if (term_is_nil(t)) { sbuf_append_cstr(sb, "[]"); return; } if (term_is_list_like_pair(t)) { term_to_sbuf_list_tr_wam(t, sb, st, dbg_dat_ptr, depth); return; } switch (t->tag) { case PL_TERM_ATOM: sbuf_append_atom(sb, t->v.atom_name); return; case PL_TERM_INT: sbuf_append_int(sb, t->v.int_value); return; case PL_TERM_BIGINT: sbuf_append_bigint(sb, t->v.bigint); return; case PL_TERM_FLOAT: sbuf_append_float(sb, t->v.float_value); return; case PL_TERM_VAR: sbuf_append_cstr(sb, t->v.var.var_name); return; case PL_TERM_STRUCT: { if ((t->v.str.arity == 1) && !strcmp(t->v.str.functor, "$VAR")) { pl_term *a = deref_term_wam(t->v.str.args[0]); if (a && term_is_integer(a)) { SLO v = 0; if (a->tag == PL_TERM_INT) { v = a->v.int_value; } else if (!bigint_fits_slo(a->v.bigint, &v)) { v = -1; } if (v >= 0) { sbuf_append_numbervar_name(sb, v); return; } } } sbuf_append_atom(sb, t->v.str.functor); sbuf_append_char(sb, '('); for (ULO i = 0; i < t->v.str.arity; i++) { if (i) { sbuf_append_char(sb, ','); } term_to_sbuf_tr_wam(t->v.str.args[i], sb, st, dbg_dat_ptr, depth + 1); } sbuf_append_char(sb, ')'); return; } default: sbuf_append_cstr(sb, ""); return; } } static void env_to_sbuf_wam(const pl_query *q, pl_wam_cell *q_cells, pl_sbuf *sb, const ULO *dbg_dat_ptr) { if (!q || !sb) { return; } if (!q_cells && q->var_count) { return; } bool any = false; for (ULO i = 0; i < q->var_count; i++) { const CHR *vname = (q->var_names && q->var_names[i]) ? q->var_names[i] : NULL; if (!vname || (vname[0] == '_')) { continue; } pl_term *value = q_cells[i].value; if (!value) { continue; } if (any) { sbuf_append_cstr(sb, ", "); } any = true; sbuf_append_cstr(sb, vname); sbuf_append_cstr(sb, " = "); pl_var_stack st; var_stack_init(&st); var_stack_push(&st, dbg_dat_ptr, (pl_var_key){.scope = q->scope, .var_id = i}); term_to_sbuf_tr_wam(value, sb, &st, dbg_dat_ptr, 0); var_stack_free(&st); } if (!any) { sbuf_append_cstr(sb, "true"); } } /* --- SUBSECTION 17.4: Term Writer (write/1, write_term/2) ---------------- */ // Term writer builtins. // write_var_map_init()/write_var_name_map_init() manage variable naming; write/write_term/writeq/write_canonical use write_term_to_sbuf(). typedef struct { pl_var_key key; const CHR *name; } pl_write_var_name_entry; typedef struct { pl_write_var_name_entry *items; ULO count; ULO cap; } pl_write_var_name_map; typedef struct { bool quoted; bool ignore_ops; bool numbervars; bool fullstop; bool nl; ULO max_depth; // 0 => unlimited const pl_write_var_name_map *var_names; } pl_write_opts; typedef struct { pl_var_key key; ULO num; } pl_write_var_entry; typedef struct { pl_write_var_entry *items; ULO count; ULO cap; } pl_write_var_map; static void write_var_map_init(pl_write_var_map *m) { memset(m, 0, sizeof(*m)); } static void write_var_map_free(pl_write_var_map *m) { free(m->items); memset(m, 0, sizeof(*m)); } static void write_var_name_map_init(pl_write_var_name_map *m) { memset(m, 0, sizeof(*m)); } static void write_var_name_map_free(pl_write_var_name_map *m) { free(m->items); memset(m, 0, sizeof(*m)); } static const CHR *write_var_name_lookup(const pl_write_var_name_map *m, pl_var_key k) { if (!m || !m->items) { return NULL; } for (ULO i = 0; i < m->count; i++) { if (var_key_eq(m->items[i].key, k)) { return m->items[i].name; } } return NULL; } static void write_var_name_add_unique(pl_write_var_name_map *m, const ULO *dbg_dat_ptr, pl_var_key k, const CHR *name) { if (!m || !name) { return; } for (ULO i = 0; i < m->count; i++) { if (var_key_eq(m->items[i].key, k)) { return; } } if (m->count == m->cap) { ULO new_cap = m->cap ? (m->cap * 2) : 32; pl_write_var_name_entry *new_items = (pl_write_var_name_entry *)realloc(m->items, sizeof(*m->items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } m->items = new_items; m->cap = new_cap; } m->items[m->count++] = (pl_write_var_name_entry){.key = k, .name = name}; } static ULO write_var_num(pl_write_var_map *m, const ULO *dbg_dat_ptr, pl_var_key k) { for (ULO i = 0; i < m->count; i++) { if (var_key_eq(m->items[i].key, k)) { return m->items[i].num; } } if (m->count == m->cap) { ULO new_cap = m->cap ? (m->cap * 2) : 64; pl_write_var_entry *new_items = (pl_write_var_entry *)realloc(m->items, sizeof(*m->items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } m->items = new_items; m->cap = new_cap; } const ULO n = m->count; m->items[m->count++] = (pl_write_var_entry){.key = k, .num = n}; return n; } static void sbuf_append_var_num(pl_sbuf *sb, ULO n) { sbuf_append_char(sb, '_'); sbuf_append_int(sb, (SLO)n); } static const pl_op_decl *lookup_prefix_op_by_name(const pl_op_overrides *ov, const CHR *name) { if (!name) { return NULL; } if (ov) { for (ULO i = 0; i < ov->count; i++) { const pl_op_decl *op = &ov->items[i]; if ((op->fix == PL_OP_PREFIX_FX || op->fix == PL_OP_PREFIX_FY) && !strcmp(op->name, name)) { return op->prec ? op : NULL; } } } for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *op = &PL_OPS[i]; if ((op->fix == PL_OP_PREFIX_FX || op->fix == PL_OP_PREFIX_FY) && !strcmp(op->name, name)) { return op; } } return NULL; } static const pl_op_decl *lookup_infix_op_by_name(const pl_op_overrides *ov, const CHR *name) { if (!name) { return NULL; } if (ov) { for (ULO i = 0; i < ov->count; i++) { const pl_op_decl *op = &ov->items[i]; if ((op->fix == PL_OP_INFIX_XFX || op->fix == PL_OP_INFIX_XFY || op->fix == PL_OP_INFIX_YFX) && !strcmp(op->name, name)) { return op->prec ? op : NULL; } } } for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *op = &PL_OPS[i]; if ((op->fix == PL_OP_INFIX_XFX || op->fix == PL_OP_INFIX_XFY || op->fix == PL_OP_INFIX_YFX) && !strcmp(op->name, name)) { return op; } } return NULL; } static const pl_op_decl *lookup_postfix_op_by_name(const pl_op_overrides *ov, const CHR *name) { if (!name) { return NULL; } if (ov) { for (ULO i = 0; i < ov->count; i++) { const pl_op_decl *op = &ov->items[i]; if ((op->fix == PL_OP_POSTFIX_XF || op->fix == PL_OP_POSTFIX_YF) && !strcmp(op->name, name)) { return op->prec ? op : NULL; } } } for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *op = &PL_OPS[i]; if ((op->fix == PL_OP_POSTFIX_XF || op->fix == PL_OP_POSTFIX_YF) && !strcmp(op->name, name)) { return op; } } return NULL; } static void sbuf_append_atom_raw(pl_sbuf *sb, const CHR *s) { if (!s || !*s) { return; } sbuf_append_cstr(sb, s); } static void sbuf_append_atom_write(pl_sbuf *sb, const CHR *s, bool quoted) { if (quoted) { sbuf_append_atom(sb, s); return; } sbuf_append_atom_raw(sb, s); } static void write_term_canonical_tr(const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, pl_write_var_map *vm, const pl_write_opts *opts, const ULO *dbg_dat_ptr, ULO depth); static void write_term_canonical_tr(const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, pl_write_var_map *vm, const pl_write_opts *opts, const ULO *dbg_dat_ptr, ULO depth) { if (!t) { sbuf_append_cstr(sb, ""); return; } if (opts && opts->max_depth && (depth >= opts->max_depth)) { sbuf_append_cstr(sb, "..."); return; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { sbuf_append_cstr(sb, "..."); return; } if (t->tag == PL_TERM_VAR) { pl_term *b = env_binding_for_var(env, t); pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; const CHR *nm = (opts && opts->var_names) ? write_var_name_lookup(opts->var_names, k) : NULL; const ULO n = nm ? 0 : write_var_num(vm, dbg_dat_ptr, k); if (!b) { if (nm) { sbuf_append_cstr(sb, nm); } else { sbuf_append_var_num(sb, n); } return; } if (st && var_stack_contains(st, k)) { if (nm) { sbuf_append_cstr(sb, nm); } else { sbuf_append_var_num(sb, n); } return; } if (st) { var_stack_push(st, dbg_dat_ptr, k); } write_term_canonical_tr(b, env, sb, st, vm, opts, dbg_dat_ptr, depth); if (st) { var_stack_pop(st); } return; } t = (const pl_term *)deref_term((pl_term *)t, env); t = term_peel_pstr_empty_const(t); if (t && t->tag == PL_TERM_VAR) { write_term_canonical_tr(t, env, sb, st, vm, opts, dbg_dat_ptr, depth); return; } if (term_is_nil(t)) { sbuf_append_cstr(sb, "[]"); return; } if (term_is_list_like_pair(t) && !term_is_list_pair(t)) { sbuf_append_atom(sb, "."); sbuf_append_char(sb, '('); const pl_term *h = NULL; const pl_term *tail = NULL; pl_term head_tmp = {0}; pl_term tail_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; if (!term_list_like_uncons_view(t, &h, &tail, &head_tmp, head_ch, &tail_tmp) || !h || !tail) { sbuf_append_cstr(sb, "[]"); sbuf_append_char(sb, ')'); return; } write_term_canonical_tr(h, env, sb, st, vm, opts, dbg_dat_ptr, depth + 1); sbuf_append_char(sb, ','); write_term_canonical_tr(tail, env, sb, st, vm, opts, dbg_dat_ptr, depth + 1); sbuf_append_char(sb, ')'); return; } switch (t->tag) { case PL_TERM_ATOM: sbuf_append_atom(sb, t->v.atom_name); return; case PL_TERM_INT: sbuf_append_int(sb, t->v.int_value); return; case PL_TERM_BIGINT: sbuf_append_bigint(sb, t->v.bigint); return; case PL_TERM_FLOAT: sbuf_append_float(sb, t->v.float_value); return; case PL_TERM_VAR: sbuf_append_cstr(sb, "_"); return; case PL_TERM_STRUCT: { if (opts && opts->numbervars && (t->v.str.arity == 1) && !strcmp(t->v.str.functor, "$VAR")) { pl_term *a = deref_term(t->v.str.args[0], env); if (a && term_is_integer(a)) { SLO v = 0; if (a->tag == PL_TERM_INT) { v = a->v.int_value; } else if (!bigint_fits_slo(a->v.bigint, &v)) { v = -1; } if (v >= 0) { sbuf_append_numbervar_name(sb, v); return; } } } sbuf_append_atom(sb, t->v.str.functor); sbuf_append_char(sb, '('); for (ULO i = 0; i < t->v.str.arity; i++) { if (i) { sbuf_append_char(sb, ','); } write_term_canonical_tr(t->v.str.args[i], env, sb, st, vm, opts, dbg_dat_ptr, depth + 1); } sbuf_append_char(sb, ')'); return; } default: sbuf_append_cstr(sb, ""); return; } } static bool term_is_prefix_op_term(const pl_op_overrides *ops, const pl_term *t, const pl_env *env) { const pl_term *d = (const pl_term *)deref_term((pl_term *)t, env); if (!d || d->tag != PL_TERM_STRUCT || d->v.str.arity != 1) { return false; } return lookup_prefix_op_by_name(ops, d->v.str.functor) != NULL; } static bool term_is_postfix_op_term(const pl_op_overrides *ops, const pl_term *t, const pl_env *env) { const pl_term *d = (const pl_term *)deref_term((pl_term *)t, env); if (!d || d->tag != PL_TERM_STRUCT || d->v.str.arity != 1) { return false; } return lookup_postfix_op_by_name(ops, d->v.str.functor) != NULL; } static void write_term_user_ctx_tr(const pl_op_overrides *ops, const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, pl_write_var_map *vm, const pl_write_opts *opts, int max_prec, const ULO *dbg_dat_ptr, ULO depth); static void write_list_user_tr(const pl_op_overrides *ops, const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, pl_write_var_map *vm, const pl_write_opts *opts, const ULO *dbg_dat_ptr, ULO depth) { if (sbuf_try_append_pstr_string_env(sb, t, env, dbg_dat_ptr)) { return; } sbuf_append_char(sb, '['); const ULO st_save = st ? st->count : 0; const pl_term *cur = t; bool first = true; pl_term tail_tmp = {0}; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); bool cycle = false; while (1) { if (!cur) { sbuf_append_cstr(sb, ""); break; } if (cur->tag == PL_TERM_VAR) { pl_term *b = env_binding_for_var(env, cur); pl_var_key k = {.scope = cur->v.var.scope, .var_id = cur->v.var.var_id}; const CHR *nm = (opts && opts->var_names) ? write_var_name_lookup(opts->var_names, k) : NULL; const ULO n = nm ? 0 : write_var_num(vm, dbg_dat_ptr, k); if (!b) { sbuf_append_char(sb, '|'); if (nm) { sbuf_append_cstr(sb, nm); } else { sbuf_append_var_num(sb, n); } break; } if (st && var_stack_contains(st, k)) { sbuf_append_char(sb, '|'); if (nm) { sbuf_append_cstr(sb, nm); } else { sbuf_append_var_num(sb, n); } break; } if (st) { var_stack_push(st, dbg_dat_ptr, k); } cur = (const pl_term *)deref_term(b, env); continue; } cur = (const pl_term *)deref_term((pl_term *)cur, env); cur = term_peel_pstr_empty_const(cur); if (cur && cur->tag == PL_TERM_VAR) { continue; } if (term_is_nil(cur)) { break; } const pl_term *h = NULL; const pl_term *tail = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; if (!term_list_like_uncons_view(cur, &h, &tail, &head_tmp, head_ch, &tail_tmp)) { sbuf_append_char(sb, '|'); write_term_user_ctx_tr(ops, cur, env, sb, st, vm, opts, 999, dbg_dat_ptr, depth + 1); break; } if (!first) { sbuf_append_char(sb, ','); } write_term_user_ctx_tr(ops, h, env, sb, st, vm, opts, 999, dbg_dat_ptr, depth + 1); first = false; cur = tail; if (list_cycle_guard_step_tr_always(&cg, env)) { cycle = true; break; } } if (cycle) { if (!first) { sbuf_append_char(sb, '|'); } sbuf_append_cstr(sb, "..."); } if (st) { st->count = st_save; } sbuf_append_char(sb, ']'); } static void write_term_user_ctx_tr(const pl_op_overrides *ops, const pl_term *t, const pl_env *env, pl_sbuf *sb, pl_var_stack *st, pl_write_var_map *vm, const pl_write_opts *opts, int max_prec, const ULO *dbg_dat_ptr, ULO depth) { if (!t) { sbuf_append_cstr(sb, ""); return; } if (opts && opts->max_depth && (depth >= opts->max_depth)) { sbuf_append_cstr(sb, "..."); return; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { sbuf_append_cstr(sb, "..."); return; } if (t->tag == PL_TERM_VAR) { pl_term *b = env_binding_for_var(env, t); pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; const CHR *nm = (opts && opts->var_names) ? write_var_name_lookup(opts->var_names, k) : NULL; const ULO n = nm ? 0 : write_var_num(vm, dbg_dat_ptr, k); if (!b) { if (nm) { sbuf_append_cstr(sb, nm); } else { sbuf_append_var_num(sb, n); } return; } if (st && var_stack_contains(st, k)) { if (nm) { sbuf_append_cstr(sb, nm); } else { sbuf_append_var_num(sb, n); } return; } if (st) { var_stack_push(st, dbg_dat_ptr, k); } write_term_user_ctx_tr(ops, b, env, sb, st, vm, opts, max_prec, dbg_dat_ptr, depth); if (st) { var_stack_pop(st); } return; } t = (const pl_term *)deref_term((pl_term *)t, env); t = term_peel_pstr_empty_const(t); if (t && t->tag == PL_TERM_VAR) { write_term_user_ctx_tr(ops, t, env, sb, st, vm, opts, max_prec, dbg_dat_ptr, depth); return; } if (term_is_nil(t)) { sbuf_append_cstr(sb, "[]"); return; } if (term_is_list_like_pair(t)) { write_list_user_tr(ops, t, env, sb, st, vm, opts, dbg_dat_ptr, depth); return; } switch (t->tag) { case PL_TERM_ATOM: sbuf_append_atom_write(sb, t->v.atom_name, opts && opts->quoted); return; case PL_TERM_INT: sbuf_append_int(sb, t->v.int_value); return; case PL_TERM_BIGINT: sbuf_append_bigint(sb, t->v.bigint); return; case PL_TERM_FLOAT: sbuf_append_float(sb, t->v.float_value); return; case PL_TERM_VAR: sbuf_append_cstr(sb, "_"); return; case PL_TERM_STRUCT: { const CHR *f = t->v.str.functor; const ULO a = t->v.str.arity; if (opts && opts->numbervars && (a == 1) && !strcmp(f, "$VAR")) { pl_term *av = deref_term(t->v.str.args[0], env); if (av && term_is_integer(av)) { SLO v = 0; if (av->tag == PL_TERM_INT) { v = av->v.int_value; } else if (!bigint_fits_slo(av->v.bigint, &v)) { v = -1; } if (v >= 0) { sbuf_append_numbervar_name(sb, v); return; } } } const pl_op_decl *pre = (a == 1) ? lookup_prefix_op_by_name(ops, f) : NULL; const pl_op_decl *in = (a == 2) ? lookup_infix_op_by_name(ops, f) : NULL; const pl_op_decl *post = (a == 1) ? lookup_postfix_op_by_name(ops, f) : NULL; const pl_op_decl *op = in ? in : (pre ? pre : post); if (op && op->prec > max_prec) { sbuf_append_char(sb, '('); write_term_user_ctx_tr(ops, t, env, sb, st, vm, opts, 1200, dbg_dat_ptr, depth + 1); sbuf_append_char(sb, ')'); return; } if (pre && pre->prec <= max_prec) { sbuf_append_cstr(sb, pre->name); const bool need_space = !strcmp(pre->name, ":-") || atom_name_is_bare(pre->name) || term_is_prefix_op_term(ops, t->v.str.args[0], env); if (need_space) { sbuf_append_char(sb, ' '); } const int arg_max = (pre->fix == PL_OP_PREFIX_FX) ? (pre->prec - 1) : pre->prec; write_term_user_ctx_tr(ops, t->v.str.args[0], env, sb, st, vm, opts, arg_max, dbg_dat_ptr, depth + 1); return; } if (post && post->prec <= max_prec) { const int arg_max = (post->fix == PL_OP_POSTFIX_XF) ? (post->prec - 1) : post->prec; write_term_user_ctx_tr(ops, t->v.str.args[0], env, sb, st, vm, opts, arg_max, dbg_dat_ptr, depth + 1); const bool need_space = atom_name_is_bare(post->name) || term_is_postfix_op_term(ops, t->v.str.args[0], env); if (need_space) { sbuf_append_char(sb, ' '); } sbuf_append_cstr(sb, post->name); return; } if (in && in->prec <= max_prec) { const int left_max = (in->fix == PL_OP_INFIX_YFX) ? in->prec : (in->prec - 1); const int right_max = (in->fix == PL_OP_INFIX_XFY) ? in->prec : (in->prec - 1); write_term_user_ctx_tr(ops, t->v.str.args[0], env, sb, st, vm, opts, left_max, dbg_dat_ptr, depth + 1); if (atom_name_is_bare(in->name)) { sbuf_append_char(sb, ' '); sbuf_append_cstr(sb, in->name); sbuf_append_char(sb, ' '); } else { sbuf_append_cstr(sb, in->name); } write_term_user_ctx_tr(ops, t->v.str.args[1], env, sb, st, vm, opts, right_max, dbg_dat_ptr, depth + 1); return; } sbuf_append_atom_write(sb, f, opts && opts->quoted); sbuf_append_char(sb, '('); for (ULO i = 0; i < a; i++) { if (i) { sbuf_append_char(sb, ','); } write_term_user_ctx_tr(ops, t->v.str.args[i], env, sb, st, vm, opts, 999, dbg_dat_ptr, depth + 1); } sbuf_append_char(sb, ')'); return; } default: sbuf_append_cstr(sb, ""); return; } } static void write_term_to_sbuf( const pl_op_overrides *ops, const pl_term *t, const pl_env *env, const pl_write_opts *opts, pl_sbuf *sb, const ULO *dbg_dat_ptr) { pl_var_stack st; var_stack_init(&st); pl_write_var_map vm; write_var_map_init(&vm); if (opts && opts->ignore_ops) { write_term_canonical_tr(t, env, sb, &st, &vm, opts, dbg_dat_ptr, 0); } else { write_term_user_ctx_tr(ops, t, env, sb, &st, &vm, opts, 1200, dbg_dat_ptr, 0); } write_var_map_free(&vm); var_stack_free(&st); } /* --- SUBSECTION 17.5: Term Reader (read/1, read_term/2) ------------------ */ // Term reader builtins and stream decoding. // stream_take_code()/stream_pushback_mem() handle lookahead; line_col_advance_bytes() and stream_advance_line_col() track source positions. static SLO stream_take_code(pl_stream *s) { if (!s) { return -1; } if (s->pushback_count) { return s->pushback[--s->pushback_count]; } const int c = fgetc(s->fp); return (c == EOF) ? -1 : (SLO)(unsigned char)c; } static void stream_pushback_mem(pl_stream *s, const ULO *dbg_dat_ptr, const char *mem, size_t n) { if (!s || !mem || !n) { return; } for (size_t i = n; i > 0; i--) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)mem[i - 1]); } } static void line_col_advance_bytes(ULO *line_io, ULO *col_io, const unsigned char *buf, size_t n) { if (!line_io || !col_io) { return; } ULO line = *line_io ? *line_io : 1; ULO col = *col_io ? *col_io : 1; if (buf && n) { for (size_t i = 0; i < n; i++) { const unsigned char c = buf[i]; if (c == '\n') { line++; col = 1; } else { col++; } } } *line_io = line; *col_io = col; } static void stream_advance_line_col(pl_stream *s, ULO start_line, ULO start_col, const CHR *buf, size_t n) { if (!s) { return; } ULO line = start_line ? start_line : 1; ULO col = start_col ? start_col : 1; line_col_advance_bytes(&line, &col, (const unsigned char *)buf, n); s->line_count = line; s->line_pos = col; } static bool stream_advance_line_col_by_reading(pl_stream *s, ULO *line_io, ULO *col_io, long nbytes) { if (!s || !s->fp || !line_io || !col_io || nbytes < 0) { return false; } unsigned char buf[8192]; while (nbytes > 0) { const size_t want = (nbytes < (long)sizeof(buf)) ? (size_t)nbytes : sizeof(buf); const size_t got = fread(buf, 1, want, s->fp); if (!got) { return false; } line_col_advance_bytes(line_io, col_io, buf, got); nbytes -= (long)got; } return true; } static bool stream_compute_line_col_for_position( pl_stream *s, long from_pos, ULO from_line, ULO from_col, long to_pos, ULO *out_line, ULO *out_col) { if (!s || !s->fp || from_pos < 0 || to_pos < from_pos) { return false; } if (fseek(s->fp, from_pos, SEEK_SET) != 0) { return false; } ULO line = from_line ? from_line : 1; ULO col = from_col ? from_col : 1; if (!stream_advance_line_col_by_reading(s, &line, &col, to_pos - from_pos)) { return false; } if (out_line) { *out_line = line; } if (out_col) { *out_col = col; } return true; } static bool stream_logical_pos(pl_stream *s, long *out_pos) { if (out_pos) { *out_pos = -1; } if (!s || !s->fp || !out_pos) { return false; } const long pos = ftell(s->fp); if (pos < 0) { return false; } const long pb = (long)s->pushback_count; long logical = pos - pb; if (logical < 0) { logical = 0; } *out_pos = logical; return true; } static bool stream_set_position(pl_stream *s, long pos) { if (!s || !s->fp || pos < 0) { return false; } ULO new_line = 0; ULO new_col = 0; bool have_line_col = false; const bool track_line_col = (s->readable && !s->binary); if (track_line_col) { long cur_pos = -1; const bool have_cur_pos = stream_logical_pos(s, &cur_pos); const ULO cur_line = s->line_count ? s->line_count : 1; const ULO cur_col = s->line_pos ? s->line_pos : 1; if (have_cur_pos && cur_pos == pos) { new_line = cur_line; new_col = cur_col; have_line_col = true; } else if (have_cur_pos && cur_pos < pos && s->line_count && s->line_pos) { have_line_col = stream_compute_line_col_for_position(s, cur_pos, cur_line, cur_col, pos, &new_line, &new_col); } else { have_line_col = stream_compute_line_col_for_position(s, 0, 1, 1, pos, &new_line, &new_col); } } stream_free_pushback(s); (void)fflush(s->fp); if (fseek(s->fp, pos, SEEK_SET) != 0) { return false; } s->eos_past = false; if (track_line_col) { if (have_line_col) { s->line_count = new_line; s->line_pos = new_col; } else { // Unknown/untracked. s->line_count = 0; s->line_pos = 0; } } return true; } static bool stream_read_term_src( pl_stream *s, pl_sbuf *out_src, bool *out_eof, bool char_conv_on, const unsigned char *char_conv_table, bool character_escapes, const ULO *dbg_dat_ptr, const CHR **out_syntax_error_reason, const CHR **out_syntax_error_pos) { if (out_eof) { *out_eof = false; } if (out_syntax_error_reason) { *out_syntax_error_reason = NULL; } if (out_syntax_error_pos) { *out_syntax_error_pos = NULL; } if (!s || !out_src) { return false; } if (!s->line_count) { s->line_count = 1; } if (!s->line_pos) { s->line_pos = 1; } const ULO start_line = s->line_count; const ULO start_col = s->line_pos; bool hit_eof = false; for (ULO guard = 0; guard < 1024 * 1024; guard++) { // Scan current buffer for a full stop token. if (out_src->buf && out_src->len) { bool rescan = false; bool need_more = false; for (;;) { pl_lex lx; lex_init(&lx, out_src->buf, char_conv_on, char_conv_table, character_escapes); rescan = false; for (;;) { pl_tok t = lex_next(&lx); if (t.type == TOK_EOF) { break; } if (t.type == TOK_ERROR) { if (lx.hard_error) { if (out_syntax_error_reason) { *out_syntax_error_reason = lx.hard_error_reason ? lx.hard_error_reason : "syntax_error"; } const size_t consumed_len = out_src->len; const CHR *raw_pos = lx.hard_error_pos ? lx.hard_error_pos : t.start; size_t err_off = 0; if (raw_pos && out_src->buf && raw_pos >= out_src->buf) { err_off = (size_t)(raw_pos - out_src->buf); } // Read a little more input for context (up to newline), but push it back so the stream position remains // at the point where the error was detected. size_t extra_len = 0; const bool saved_eos_past = s->eos_past; for (size_t i = 0; i < 256; i++) { const SLO c = stream_take_code(s); if (c == -1) { break; } sbuf_append_char(out_src, (char)(unsigned char)c); extra_len++; if ((unsigned char)c == '\n') { break; } } if (extra_len) { stream_pushback_mem(s, dbg_dat_ptr, out_src->buf + consumed_len, extra_len); } s->eos_past = saved_eos_past; if (out_syntax_error_pos) { *out_syntax_error_pos = (out_src->buf && err_off <= out_src->len) ? (out_src->buf + err_off) : out_src->buf; } stream_advance_line_col(s, start_line, start_col, out_src->buf, consumed_len); return false; } // The buffer may contain an incomplete token (e.g. an unterminated quoted atom) that will become valid once // more characters are read from the stream. need_more = true; break; } if (t.type != TOK_DOT) { continue; } const size_t dot_pos = (size_t)(t.start - out_src->buf); const bool at_buf_end = (dot_pos + 1) >= out_src->len; if (at_buf_end && !hit_eof) { // '.' at end of buffer is ambiguous: read one more character to disambiguate. const SLO c = stream_take_code(s); if (c == -1) { hit_eof = true; s->eos_past = true; // Accept '.' as terminator at EOF. out_src->buf[out_src->len] = '\0'; stream_advance_line_col(s, start_line, start_col, out_src->buf, out_src->len); return true; } sbuf_append_char(out_src, (char)(unsigned char)c); rescan = true; break; } // Push back any data after '.' and truncate buffer to include '.'. const size_t term_len = dot_pos + 1; if (out_src->len > term_len) { stream_pushback_mem(s, dbg_dat_ptr, out_src->buf + term_len, out_src->len - term_len); } out_src->len = term_len; out_src->buf[term_len] = '\0'; stream_advance_line_col(s, start_line, start_col, out_src->buf, out_src->len); return true; } if (need_more || !rescan) { break; } } } // Need more data. const SLO c = stream_take_code(s); if (c == -1) { hit_eof = true; s->eos_past = true; break; } sbuf_append_char(out_src, (char)(unsigned char)c); } // EOF before a full stop: only succeed if nothing but whitespace/comments were read. if (out_src->buf && out_src->len) { pl_lex lx; lex_init(&lx, out_src->buf, char_conv_on, char_conv_table, character_escapes); const pl_tok t = lex_next(&lx); if (t.type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected end of stream while reading term", dbg_dat_ptr); } } if (out_eof) { *out_eof = true; } stream_advance_line_col(s, start_line, start_col, out_src->buf, out_src->len); return true; } static void env_to_sbuf(const pl_query *q, const pl_env *env, pl_sbuf *sb, const ULO *dbg_dat_ptr) { bool any = false; for (ULO i = 0; i < q->var_count; i++) { const CHR *vname = (q->var_names && q->var_names[i]) ? q->var_names[i] : NULL; if (!vname || (vname[0] == '_')) { continue; } pl_term *value = env_lookup(env, q->scope, i); if (!value) { continue; } if (any) { sbuf_append_cstr(sb, ", "); } any = true; sbuf_append_cstr(sb, vname); sbuf_append_cstr(sb, " = "); pl_var_stack st; var_stack_init(&st); var_stack_push(&st, dbg_dat_ptr, (pl_var_key){.scope = q->scope, .var_id = i}); term_to_sbuf_tr(value, env, sb, &st, dbg_dat_ptr, 0); var_stack_free(&st); } if (!any) { sbuf_append_cstr(sb, "true"); } } static pl_term *clone_term_with_scope(const pl_term *src, const pl_scope *from_scope, const pl_scope *to_scope, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!src) { return NULL; } src = term_peel_pstr_empty_const(src); if (!src) { return NULL; } const unsigned char *pbytes = NULL; ULO plen = 0; const pl_term *ptail = NULL; if (term_pstr_run_bytes_len_tail_const(src, &pbytes, &plen, &ptail)) { pl_term *tail_c = ptail ? clone_term_with_scope(ptail, from_scope, to_scope, rt_ctrl, dbg_dat_ptr) : NULL; if (!tail_c) { tail_c = make_nil_rt(dbg_dat_ptr); } return make_pstr_bytes_rt(rt_ctrl, dbg_dat_ptr, pbytes, plen, tail_c); } pl_term *dst = (pl_term *)pool_alloc(rt_ctrl, sizeof(*dst), dbg_dat_ptr); dst->tag = src->tag; dst->builtin = src->builtin; dst->reserved16 = src->reserved16; switch (src->tag) { case PL_TERM_ATOM: dst->v.atom_name = src->v.atom_name; return dst; case PL_TERM_INT: dst->v.int_value = src->v.int_value; return dst; case PL_TERM_BIGINT: dst->v.bigint = src->v.bigint; return dst; case PL_TERM_FLOAT: dst->v.float_value = src->v.float_value; return dst; case PL_TERM_VAR: dst->v.var.scope = (src->v.var.scope == from_scope) ? to_scope : src->v.var.scope; dst->v.var.var_id = src->v.var.var_id; dst->v.var.var_name = src->v.var.var_name; return dst; case PL_TERM_STRUCT: dst->v.str.arity = src->v.str.arity; dst->v.str.functor = src->v.str.functor; if (dst->v.str.arity) { dst->v.str.args = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * dst->v.str.arity, dbg_dat_ptr); for (ULO i = 0; i < dst->v.str.arity; i++) { dst->v.str.args[i] = clone_term_with_scope(src->v.str.args[i], from_scope, to_scope, rt_ctrl, dbg_dat_ptr); } } else { dst->v.str.args = NULL; } return dst; default: break; } return dst; } typedef struct { pl_term *terms; ULO term_cap; ULO term_pos; pl_term **args; ULO arg_cap; ULO arg_pos; } pl_term_arena; static void term_count_nodes_args_tr(const pl_term *t, ULO *nodes, ULO *args, ULO depth) { if (!t || FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return; } if (nodes) { (*nodes)++; } if (t->tag == PL_TERM_STRUCT) { if (args) { (*args) += t->v.str.arity; } for (ULO i = 0; i < t->v.str.arity; i++) { term_count_nodes_args_tr(t->v.str.args ? t->v.str.args[i] : NULL, nodes, args, depth + 1); } } } static void clause_compute_tpl_sizes(pl_clause *cl) { if (!cl) { return; } ULO nodes = 0; ULO args = 0; term_count_nodes_args_tr(cl->head, &nodes, &args, 0); if (cl->body_count && cl->body) { for (ULO i = 1; i <= cl->body_count; i++) { term_count_nodes_args_tr(cl->body[i], &nodes, &args, 0); } } if (cl->env && cl->env->count && cl->env->items) { for (ULO i = 0; i < cl->env->count; i++) { const pl_binding *b = &cl->env->items[i]; if (!b || (b->scope != cl->scope)) { continue; } term_count_nodes_args_tr(b->value, &nodes, &args, 0); } } if (!nodes) { nodes = 1; } cl->tpl_nodes = nodes; cl->tpl_args = args; } static pl_term *arena_alloc_term(pl_term_arena *a, const ULO *dbg_dat_ptr) { if (!a || !a->terms || (a->term_pos >= a->term_cap)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: clause instantiation arena exhausted", dbg_dat_ptr); } return &a->terms[a->term_pos++]; } static pl_term **arena_alloc_args(pl_term_arena *a, ULO arity, const ULO *dbg_dat_ptr) { if (!arity) { return NULL; } if (!a || !a->args || ((a->arg_pos + arity) > a->arg_cap)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: clause instantiation arena exhausted", dbg_dat_ptr); } pl_term **p = &a->args[a->arg_pos]; a->arg_pos += arity; return p; } static pl_term *clone_term_with_scope_arena(const pl_term *src, const pl_scope *from_scope, const pl_scope *to_scope, pl_term_arena *arena, const ULO *dbg_dat_ptr, ULO depth) { if (!src) { return NULL; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return NULL; } if (!arena) { return NULL; } src = term_peel_pstr_empty_const(src); if (!src) { return NULL; } if (term_is_pstr(src)) { // Packed strings are immutable and scope-free: safe to reuse the source pointer. return (pl_term *)src; } pl_term *dst = arena_alloc_term(arena, dbg_dat_ptr); dst->tag = src->tag; dst->builtin = src->builtin; dst->reserved16 = src->reserved16; switch (src->tag) { case PL_TERM_ATOM: dst->v.atom_name = src->v.atom_name; return dst; case PL_TERM_INT: dst->v.int_value = src->v.int_value; return dst; case PL_TERM_BIGINT: dst->v.bigint = src->v.bigint; return dst; case PL_TERM_FLOAT: dst->v.float_value = src->v.float_value; return dst; case PL_TERM_VAR: dst->v.var.scope = (src->v.var.scope == from_scope) ? to_scope : src->v.var.scope; dst->v.var.var_id = src->v.var.var_id; dst->v.var.var_name = src->v.var.var_name; return dst; case PL_TERM_STRUCT: dst->v.str.arity = src->v.str.arity; dst->v.str.functor = src->v.str.functor; dst->v.str.args = arena_alloc_args(arena, dst->v.str.arity, dbg_dat_ptr); for (ULO i = 0; i < dst->v.str.arity; i++) { dst->v.str.args[i] = clone_term_with_scope_arena( src->v.str.args ? src->v.str.args[i] : NULL, from_scope, to_scope, arena, dbg_dat_ptr, depth + 1); } return dst; default: return dst; } return dst; } /* ============================================================================ * SECTION 18: WAMVM Instantiation & Bytecode Model * WAMVM clause instantiation and bytecode metadata. * ============================================================================ */ /* --- SUBSECTION 18.1: Reduced Term Instantiation ------------------------- */ // Reduced term instantiation for WAMVM. // wamvm_vars_init() pre-allocates variable cells for bytecode execution. static inline void wamvm_vars_init(pl_term *vars, ULO var_count, const pl_scope *scope) { if (!vars || !scope) { return; } for (ULO i = 0; i < var_count; i++) { vars[i].tag = PL_TERM_VAR; vars[i].builtin = 0; vars[i].reserved16 = 0; vars[i].v.var.scope = scope; vars[i].v.var.var_id = i; vars[i].v.var.var_name = NULL; } } static pl_term *wamvm_instantiate_term_arena(const pl_term *src, const pl_scope *from_scope, pl_term *vars, ULO var_count, pl_term_arena *arena, const ULO *dbg_dat_ptr, ULO depth) { if (!src) { return NULL; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return NULL; } src = term_peel_pstr_empty_const(src); if (!src) { return NULL; } if (term_is_pstr(src)) { // Packed strings are immutable and scope-free: safe to reuse the source pointer. return (pl_term *)src; } switch (src->tag) { case PL_TERM_ATOM: case PL_TERM_INT: case PL_TERM_BIGINT: case PL_TERM_FLOAT: // Immutable leaf: safe to reuse the source pointer. return (pl_term *)src; case PL_TERM_VAR: if (src->v.var.scope == from_scope) { if (!vars || src->v.var.var_id >= var_count) { return NULL; } return &vars[src->v.var.var_id]; } // Unexpected foreign-scope variable; preserve it. return (pl_term *)src; case PL_TERM_STRUCT: break; default: break; } // If a subtree has no variables, we can reuse it directly (it does not // contain any clause-scope variable references that require remapping). if (term_is_syntactic_ground(src, depth)) { return (pl_term *)src; } if (!arena) { return NULL; } pl_term *dst = arena_alloc_term(arena, dbg_dat_ptr); dst->tag = PL_TERM_STRUCT; dst->builtin = src->builtin; dst->reserved16 = src->reserved16; dst->v.str.arity = src->v.str.arity; dst->v.str.functor = src->v.str.functor; dst->v.str.args = arena_alloc_args(arena, dst->v.str.arity, dbg_dat_ptr); for (ULO i = 0; i < dst->v.str.arity; i++) { dst->v.str.args[i] = wamvm_instantiate_term_arena(src->v.str.args ? src->v.str.args[i] : NULL, from_scope, vars, var_count, arena, dbg_dat_ptr, depth + 1); } return dst; } static bool wamvm_unify_against_clause_term(pl_term *goal_term, const pl_term *clause_term, const pl_scope *clause_scope, pl_term *vars, ULO var_count, pl_wam_trail *trail, pl_term_arena *arena, const ULO *dbg_dat_ptr, ULO depth) { if (!goal_term || !clause_term || !trail) { return false; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return false; } // Clause variable (to be unified with the local per-invocation var). if (clause_term->tag == PL_TERM_VAR && clause_term->v.var.scope == clause_scope) { if (!vars || clause_term->v.var.var_id >= var_count) { return false; } return unify_terms_wam(goal_term, &vars[clause_term->v.var.var_id], trail, dbg_dat_ptr); } // Fast path for ground subterms: unify directly, allowing goal variables to bind. if ((clause_term->tag != PL_TERM_STRUCT) || term_is_syntactic_ground(clause_term, depth)) { return unify_terms_wam(goal_term, (pl_term *)clause_term, trail, dbg_dat_ptr); } // Non-ground structure: avoid cloning the structure when possible by // descending into the goal term. If the goal is a variable, materialize an // instantiated structure and bind it. pl_term *g = deref_term_wam(goal_term); if (!g) { return false; } if (g->tag == PL_TERM_VAR) { pl_term *inst = wamvm_instantiate_term_arena(clause_term, clause_scope, vars, var_count, arena, dbg_dat_ptr, depth); if (!inst) { return false; } return unify_terms_wam(g, inst, trail, dbg_dat_ptr); } if (g->tag != PL_TERM_STRUCT || !g->v.str.functor || !g->v.str.args) { return false; } if (g->v.str.arity != clause_term->v.str.arity || strcmp(g->v.str.functor, clause_term->v.str.functor)) { return false; } for (ULO i = 0; i < g->v.str.arity; i++) { if (!wamvm_unify_against_clause_term(g->v.str.args[i], clause_term->v.str.args ? clause_term->v.str.args[i] : NULL, clause_scope, vars, var_count, trail, arena, dbg_dat_ptr, depth + 1)) { return false; } } return true; } /* --- SUBSECTION 18.2: Bytecode Structures -------------------------------- */ // Bytecode structures and WAMVM helpers. // clause_arena_alloc() manages clause arenas; cut_none()/cut_to() build cut signals; wamvm_matchable_head_key_eq() compares heads. enum { PL_WAMVM_MATCHABLE_MAX = 32 }; enum { PL_WAMVM_MATCHABLE_ARITY_MAX = 16 }; typedef enum { PL_WAMVM_OP_CALL = 1, // call a (possibly built-in) goal PL_WAMVM_OP_PROCEED = 2 // clause finished } pl_wamvm_op; typedef struct { pl_wamvm_op op; const pl_term *goal; // valid when op==PL_WAMVM_OP_CALL } pl_wamvm_insn; typedef struct { const pl_clause *cl; // original source clause (head/body templates) ULO insn_count; // includes final PROCEED const pl_wamvm_insn *insn; // instruction stream (read-only) } pl_wamvm_clause_code; typedef struct { const CHR *name; ULO arity; ULO clause_count; const pl_wamvm_clause_code *clauses; // in classic clause order unsigned char needs_cut_barrier; // 1 when predicate may execute !/0 uint16_t matchable_arg_mask; // bits for args worth matchability checks (arity<=16), 0 disables } pl_wamvm_pred_code; typedef struct { const pl_program *prog; unsigned long clause_epoch; // snapshot of prog->clause_epoch when built ULO pred_count; const pl_wamvm_pred_code *preds; // 0-based array } pl_wamvm_prog_code; static FLOWLOG_TLS const pl_wamvm_prog_code *g_wamvm_code = NULL; static FLOWLOG_TLS bool g_wamvm_vm_used = false; // Optional WAMVM profiling (disabled by default). static FLOWLOG_TLS int g_wamvm_prof_nesting = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_snap_captures = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_snap_capture_frames = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_snap_restores = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_snap_restore_frames = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_pred_calls = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_clause_attempts = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_clause_matches = 0; static FLOWLOG_TLS uint64_t g_wamvm_prof_pred_fail = 0; static bool wamvm_matchable_head_key_eq(const pl_term *a, const pl_term *b) { if (!a || !b) { return false; } if (term_is_integer(a) || term_is_integer(b)) { return term_is_integer(a) && term_is_integer(b) && term_integer_equal(a, b); } if (a->tag != b->tag) { return false; } switch (a->tag) { case PL_TERM_ATOM: { const CHR *an = a->v.atom_name; const CHR *bn = b->v.atom_name; if (an == bn) { return true; } if (!an || !bn) { return false; } return !strcmp(an, bn); } case PL_TERM_INT: return a->v.int_value == b->v.int_value; case PL_TERM_BIGINT: return term_integer_equal(a, b); case PL_TERM_FLOAT: return a->v.float_value == b->v.float_value; case PL_TERM_STRUCT: { if (a->v.str.arity != b->v.str.arity) { return false; } const CHR *af = a->v.str.functor; const CHR *bf = b->v.str.functor; if (af == bf) { return true; } if (!af || !bf) { return false; } return !strcmp(af, bf); } default: return false; } } static const pl_wamvm_prog_code *wamvm_program_code_build(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog) { return NULL; } // WAMVM uses the predicate index to build per-predicate clause code tables. // Ensure the index is current so dynamic database updates (assert/retract/etc) // are visible to subsequent predicate calls. prog_index_ensure(prog, rt_ctrl, dbg_dat_ptr); if (!prog->pred_index) { return NULL; } pl_pred_index *idx = prog->pred_index; const ULO pred_count = idx->pred_count; pl_wamvm_prog_code *pc = (pl_wamvm_prog_code *)pool_alloc(rt_ctrl, sizeof(*pc), dbg_dat_ptr); memset(pc, 0, sizeof(*pc)); pc->prog = prog; pc->clause_epoch = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); pc->pred_count = pred_count; if (!pred_count) { pc->preds = NULL; return pc; } pl_wamvm_pred_code *preds = (pl_wamvm_pred_code *)pool_alloc(rt_ctrl, sizeof(*preds) * pred_count, dbg_dat_ptr); memset(preds, 0, sizeof(*preds) * pred_count); pc->preds = preds; for (ULO pi = 0; pi < pred_count; pi++) { pl_pred_index_entry *e = &idx->preds[pi]; if (!e) { continue; } pl_wamvm_pred_code *pd = &preds[pi]; pd->name = e->name; pd->arity = e->arity; pd->clause_count = e->clause_count; pd->needs_cut_barrier = 0; pd->matchable_arg_mask = 0; // Conservative cut analysis: if any clause body contains `!/0`, this // predicate needs its own cut barrier at call entry. if (e->clauses && e->clause_count) { for (ULO ci = 0; ci < e->clause_count && !pd->needs_cut_barrier; ci++) { const pl_clause *cl = e->clauses[ci]; if (!cl || !cl->body || !cl->body_count) { continue; } for (ULO gi = 0; gi < cl->body_count; gi++) { const pl_term *g = cl->body[gi + 1]; if (!g) { continue; } if (g->tag == PL_TERM_ATOM && g->v.atom_name && !strcmp(g->v.atom_name, "!")) { pd->needs_cut_barrier = 1; break; } if (g->builtin && (g->builtin == (uint32_t)PL_BI_CUT_0)) { pd->needs_cut_barrier = 1; break; } } } } // Precompute which argument positions are worth shallow matchability checks. // We enable it when either: // - there are >=2 distinct non-var head patterns at that position, or // - there is exactly one non-var pattern and at least one clause-local // variable at that position (e.g. base case constant vs recursive var), // excluding the common list-cons functor '.'/2 to avoid overhead in // predicates like select_/3 where this doesn't prune in practice. if (e->clauses && e->clause_count && (e->clause_count > 1) && (e->clause_count <= (ULO)PL_WAMVM_MATCHABLE_MAX) && (pd->arity > 0) && (pd->arity <= (ULO)PL_WAMVM_MATCHABLE_ARITY_MAX)) { uint16_t mask = 0; for (ULO ai = 0; ai < pd->arity; ai++) { const pl_term *seen_nonvar[2] = {0}; ULO seen_nonvar_count = 0; bool has_var = false; for (ULO ci = 0; ci < e->clause_count && seen_nonvar_count < 2; ci++) { const pl_clause *cl = e->clauses[ci]; if (!cl || !cl->head || (cl->head->tag != PL_TERM_STRUCT) || !cl->head->v.str.args) { continue; } const pl_term *harg = cl->head->v.str.args[ai]; if (!harg) { continue; } if (harg->tag == PL_TERM_VAR && harg->v.var.scope == cl->scope) { has_var = true; continue; } bool dup = false; for (ULO si = 0; si < seen_nonvar_count; si++) { if (wamvm_matchable_head_key_eq(seen_nonvar[si], harg)) { dup = true; break; } } if (!dup) { seen_nonvar[seen_nonvar_count++] = harg; } } bool worth = false; if (seen_nonvar_count >= 2) { worth = true; } else if ((seen_nonvar_count == 1) && has_var) { const pl_term *k = seen_nonvar[0]; if (k) { if (k->tag == PL_TERM_ATOM || k->tag == PL_TERM_INT || k->tag == PL_TERM_FLOAT) { worth = true; } else if (k->tag == PL_TERM_STRUCT) { const CHR *fn = k->v.str.functor; const ULO ar = k->v.str.arity; if (!fn || (ar != 2) || strcmp(fn, ".")) { worth = true; } } } } if (worth) { mask |= (uint16_t)(1u << ai); } } pd->matchable_arg_mask = mask; } if (!e->clauses || !e->clause_count) { pd->clauses = NULL; continue; } pl_wamvm_clause_code *cc = (pl_wamvm_clause_code *)pool_alloc(rt_ctrl, sizeof(*cc) * e->clause_count, dbg_dat_ptr); memset(cc, 0, sizeof(*cc) * e->clause_count); pd->clauses = cc; for (ULO ci = 0; ci < e->clause_count; ci++) { const pl_clause *cl = e->clauses[ci]; cc[ci].cl = cl; if (!cl) { cc[ci].insn_count = 0; cc[ci].insn = NULL; continue; } const ULO body_n = cl->body_count; const ULO insn_count = body_n + 1; // +PROCEED pl_wamvm_insn *insn = (pl_wamvm_insn *)pool_alloc(rt_ctrl, sizeof(*insn) * insn_count, dbg_dat_ptr); for (ULO gi = 0; gi < body_n; gi++) { insn[gi] = (pl_wamvm_insn){.op = PL_WAMVM_OP_CALL, .goal = (cl->body ? cl->body[gi + 1] : NULL)}; } insn[insn_count - 1] = (pl_wamvm_insn){.op = PL_WAMVM_OP_PROCEED, .goal = NULL}; cc[ci].insn_count = insn_count; cc[ci].insn = insn; } } return pc; } static pl_term_arena clause_arena_alloc(const pl_clause *cl, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_term_arena a = {0}; if (!cl || !cl->tpl_nodes) { return a; } const size_t term_bytes = (size_t)cl->tpl_nodes * sizeof(pl_term); const size_t align = sizeof(void *); const size_t term_bytes_aligned = (term_bytes + align - 1) & ~(align - 1); const size_t total_bytes = term_bytes_aligned + (size_t)cl->tpl_args * sizeof(pl_term *); void *mem = pool_alloc(rt_ctrl, (ULO)total_bytes, dbg_dat_ptr); a.terms = (pl_term *)mem; a.term_cap = cl->tpl_nodes; a.term_pos = 0; a.args = (pl_term **)((char *)mem + term_bytes_aligned); a.arg_cap = cl->tpl_args; a.arg_pos = 0; return a; } static bool wamvm_alloc_scope_cells_vars(pl_wam_state *st, ULO var_count, pl_scope **out_scope, pl_wam_cell **out_cells, pl_term **out_vars, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (out_scope) { *out_scope = NULL; } if (out_cells) { *out_cells = NULL; } if (out_vars) { *out_vars = NULL; } if (!st || !out_scope || !out_cells || !out_vars) { return false; } const size_t align_cells = _Alignof(pl_wam_cell); const size_t align_vars = _Alignof(pl_term); size_t off = sizeof(pl_scope); const size_t cells_off = (off + align_cells - 1) & ~(align_cells - 1); const size_t cells_bytes = (size_t)var_count * sizeof(pl_wam_cell); off = cells_off + cells_bytes; const size_t vars_off = (off + align_vars - 1) & ~(align_vars - 1); const size_t vars_bytes = (size_t)var_count * sizeof(pl_term); const size_t total = vars_off + vars_bytes; unsigned char *mem = (unsigned char *)pool_alloc(rt_ctrl, (ULO)total, dbg_dat_ptr); pl_scope *scope = (pl_scope *)mem; scope->reserved = 0; scope->var_count = var_count; pl_wam_cell *cells = var_count ? (pl_wam_cell *)(mem + cells_off) : NULL; if (cells_bytes) { memset(cells, 0, cells_bytes); } pl_term *vars = var_count ? (pl_term *)(mem + vars_off) : NULL; if (vars) { wamvm_vars_init(vars, var_count, scope); } wam_state_push_scope_with_cells(st, scope, cells, var_count, rt_ctrl, dbg_dat_ptr); *out_scope = scope; *out_cells = cells; *out_vars = vars; return true; } static void env_apply_clause_bindings_arena(const pl_clause *cl, const pl_scope *to_scope, pl_env *env, pl_term_arena *arena, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!cl || !cl->env || !cl->env->count || !env || !to_scope) { return; } for (ULO i = 0; i < cl->env->count; i++) { const pl_binding *b = &cl->env->items[i]; if (!b || (b->scope != cl->scope)) { continue; } pl_term *val = arena ? clone_term_with_scope_arena(b->value, cl->scope, to_scope, arena, dbg_dat_ptr, 0) : clone_term_with_scope(b->value, cl->scope, to_scope, rt_ctrl, dbg_dat_ptr); env_bind(env, rt_ctrl, dbg_dat_ptr, to_scope, b->var_id, val); } } static void env_apply_clause_bindings(const pl_clause *cl, const pl_scope *to_scope, pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!cl || !cl->env || !cl->env->count || !env || !to_scope) { return; } for (ULO i = 0; i < cl->env->count; i++) { const pl_binding *b = &cl->env->items[i]; if (!b || (b->scope != cl->scope)) { continue; } pl_term *val = clone_term_with_scope(b->value, cl->scope, to_scope, rt_ctrl, dbg_dat_ptr); env_bind(env, rt_ctrl, dbg_dat_ptr, to_scope, b->var_id, val); } } typedef struct { bool cut; bool except; const void *target; pl_term *except_term; pl_env *except_env; } pl_cut_signal; static pl_cut_signal cut_none(void) { return (pl_cut_signal){0}; } static pl_cut_signal cut_to(const void *t) { return (pl_cut_signal){.cut = true, .target = t}; } static pl_cut_signal except_to(const void *t, pl_term *term, pl_env *env) { pl_cut_signal sig = {.except = true, .target = t, .except_term = term, .except_env = env}; const pl_program *prog = g_current_prog; if (prog && prog->flag_trace) { const long best = trace_storage_top_for_depth(g_trace_depth); // Try to attribute the exception to the nearest user predicate frame. long pick = -1; for (long d = best; d >= 0; d--) { const pl_trace_frame *f = trace_frame_get((ULO)d); if (!f->name || !f->goal) { continue; } if (trace_goal_name_hidden_prolog(f->name)) { continue; } if (builtin_pred_defined(f->name, f->arity)) { continue; } pick = d; break; } if (pick < 0) { pick = best; } const pl_trace_frame *f = NULL; if (pick >= 0) { f = trace_frame_get((ULO)pick); } pl_sbuf sb_goal; sbuf_init(&sb_goal, NULL, NULL); if (f && f->goal) { if (g_wam_state) { pl_var_stack st; var_stack_init(&st); term_to_sbuf_tr_wam(f->goal, &sb_goal, &st, NULL, 0); var_stack_free(&st); } else { term_to_sbuf(f->goal, NULL, &sb_goal, NULL); } } pl_sbuf sb_exc; sbuf_init(&sb_exc, NULL, NULL); if (term) { term_to_sbuf(term, env, &sb_exc, NULL); } const unsigned long pick_out = (pick >= 0) ? (unsigned long)pick : 0ul; if (sb_goal.len) { (void)fprintf(stderr, "xp %5lu EXCEPTION %s: %s\n", pick_out, sb_goal.buf ? sb_goal.buf : "", sb_exc.buf ? sb_exc.buf : ""); } else { (void)fprintf(stderr, "xp %5lu EXCEPTION %s\n", pick_out, sb_exc.buf ? sb_exc.buf : ""); } sbuf_free(&sb_exc); sbuf_free(&sb_goal); } return sig; } // WAMVM cut barrier (used by the bytecode VM and its OR-par jobs). // Note: `cp_base` is interpreted relative to a specific VM instance's // choicepoint stack, so barrier objects are not generally shareable between // independent VM runs. typedef struct pl_wamvm_barrier { const struct pl_wamvm_barrier *prev; ULO cp_base; // choicepoint stack size at barrier entry } pl_wamvm_barrier; /* ============================================================================ * SECTION 19: Exceptions & Errors * ISO-style error terms and exception helpers. * ============================================================================ */ /* --- SUBSECTION 19.1: Error Term Constructors ---------------------------- */ // ISO error term constructors. // alloc_empty_env_rt(), make_pred_indicator_rt(), and make_error_rt() build error/2 terms and context. static pl_env *alloc_empty_env_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_env *env = (pl_env *)pool_alloc(rt_ctrl, sizeof(*env), dbg_dat_ptr); memset(env, 0, sizeof(*env)); return env; } static pl_term *make_pred_indicator_rt(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *name, ULO arity) { pl_term *pi = make_struct_rt(rt_ctrl, dbg_dat_ptr, "/", 2); pi->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, name ? name : ""); pi->v.str.args[1] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)arity); return pi; } static pl_term *make_error_rt(pl_term *formal, pl_term *context, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_term *err = make_struct_rt(rt_ctrl, dbg_dat_ptr, "error", 2); err->v.str.args[0] = formal ? formal : make_atom_rt(rt_ctrl, dbg_dat_ptr, "system_error"); err->v.str.args[1] = context ? context : make_atom_rt(rt_ctrl, dbg_dat_ptr, "context"); return err; } /* --- SUBSECTION 19.2: Exception Helpers ---------------------------------- */ // Exception helpers and inference-limit enforcement. // throw_* helpers raise ISO errors; flowlog_inference_limit_local_set()/clear() manage per-thread limits; throw_inference_limit_exceeded() reports budget errors. static pl_cut_signal throw_instantiation_error(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *context_atom) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_atom_rt(rt_ctrl, dbg_dat_ptr, context_atom ? context_atom : "context"); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_instantiation_error_pi(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_type_error(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *expected_type, pl_term *culprit, const pl_env *env_in, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *cul_copy = culprit ? copy_term_tr(culprit, env_in, env, &m, rt_ctrl, dbg_dat_ptr, 0) : NULL; copy_var_map_free(&m); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "type_error", 2); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, expected_type ? expected_type : "type"); formal->v.str.args[1] = cul_copy ? cul_copy : make_atom_rt(rt_ctrl, dbg_dat_ptr, "culprit"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_domain_error(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *domain, pl_term *culprit, const pl_env *env_in, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *cul_copy = culprit ? copy_term_tr(culprit, env_in, env, &m, rt_ctrl, dbg_dat_ptr, 0) : NULL; copy_var_map_free(&m); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "domain_error", 2); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, domain ? domain : "domain"); formal->v.str.args[1] = cul_copy ? cul_copy : make_atom_rt(rt_ctrl, dbg_dat_ptr, "culprit"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_evaluation_error(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *err_atom, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "evaluation_error", 1); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, err_atom ? err_atom : "error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_inference_limit_exceeded(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *t = make_atom_rt(rt_ctrl, dbg_dat_ptr, "inference_limit_exceeded"); return except_to(exc_barrier, t, env); } static inline SLO flowlog_slo_clamp_size(size_t v) { if (v > (size_t)LONG_MAX) { return (SLO)LONG_MAX; } return (SLO)v; } static pl_cut_signal throw_resource_error_stack_limit(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, size_t limit, size_t used) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "resource_error", 1); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "stack"); pl_term *ctx = make_struct_rt(rt_ctrl, dbg_dat_ptr, "c_stack_limit", 2); ctx->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, flowlog_slo_clamp_size(limit)); ctx->v.str.args[1] = make_int_rt(rt_ctrl, dbg_dat_ptr, flowlog_slo_clamp_size(used)); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static inline void flowlog_inference_limit_local_set(uint64_t limit) { g_inference_limit = limit; g_inference_count = 0; } static inline void flowlog_inference_limit_local_clear(void) { g_inference_limit = 0; g_inference_count = 0; } static inline void flowlog_inference_limit_shared_set(pl_parallel_state *st, uint64_t limit) { if (!st) { flowlog_inference_limit_local_set(limit); return; } atomic_store_explicit(&st->shared_inference_limit, limit, memory_order_relaxed); atomic_store_explicit(&st->shared_inference_count, 0, memory_order_relaxed); } static inline void flowlog_inference_limit_shared_clear(pl_parallel_state *st) { if (!st) { return; } atomic_store_explicit(&st->shared_inference_limit, 0, memory_order_relaxed); atomic_store_explicit(&st->shared_inference_count, 0, memory_order_relaxed); } static inline pl_cut_signal flowlog_inference_limit_tick(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (g_cstack_limit_bytes) { const size_t used = flowlog_cstack_used_bytes(); if (used >= g_cstack_limit_bytes) { if (!g_cstack_limit_tripped) { g_cstack_limit_tripped = true; return throw_resource_error_stack_limit(exc_barrier, rt_ctrl, dbg_dat_ptr, g_cstack_limit_bytes, used); } } else if (g_cstack_limit_tripped && used < (g_cstack_limit_bytes / 2)) { g_cstack_limit_tripped = false; } } // Shared cap across OR/AND-par worker threads when running within a parallel query. if (g_par_state) { const uint64_t limit = atomic_load_explicit(&g_par_state->shared_inference_limit, memory_order_relaxed); if (limit) { // Use the pre-increment (old) value to match the per-thread semantics below. const uint64_t count = atomic_fetch_add_explicit(&g_par_state->shared_inference_count, 1, memory_order_relaxed); if (count >= limit) { // Disable the limit once it fires so catch handlers can run without immediately // re-triggering the same exception before they have a chance to reset it. atomic_store_explicit(&g_par_state->shared_inference_limit, 0, memory_order_relaxed); // Best-effort cancellation: the shared limit can be hit by one worker while // others are still running. Cooperatively stop the current OR/AND-par job. if (g_cancel_flag) { atomic_store((atomic_int *)g_cancel_flag, 1); } return throw_inference_limit_exceeded(exc_barrier, rt_ctrl, dbg_dat_ptr); } return cut_none(); } } if (!g_inference_limit) { return cut_none(); } if (g_inference_count++ >= g_inference_limit) { g_inference_limit = 0; return throw_inference_limit_exceeded(exc_barrier, rt_ctrl, dbg_dat_ptr); } return cut_none(); } static pl_cut_signal throw_existence_error(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *object_type, pl_term *culprit, const pl_env *env_in, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *cul_copy = culprit ? copy_term_tr(culprit, env_in, env, &m, rt_ctrl, dbg_dat_ptr, 0) : NULL; copy_var_map_free(&m); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "existence_error", 2); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, object_type ? object_type : "object"); formal->v.str.args[1] = cul_copy ? cul_copy : make_atom_rt(rt_ctrl, dbg_dat_ptr, "culprit"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_permission_error(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *operation, const CHR *object_type, pl_term *culprit, const pl_env *env_in, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *cul_copy = culprit ? copy_term_tr(culprit, env_in, env, &m, rt_ctrl, dbg_dat_ptr, 0) : NULL; copy_var_map_free(&m); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "permission_error", 3); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, operation ? operation : "operation"); formal->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, object_type ? object_type : "object"); formal->v.str.args[2] = cul_copy ? cul_copy : make_atom_rt(rt_ctrl, dbg_dat_ptr, "culprit"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_representation_error(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *flag, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "representation_error", 1); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, flag ? flag : "flag"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } static pl_cut_signal throw_syntax_error_pi(const void *exc_barrier, const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *reason, const CHR *pred_name, ULO pred_arity) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "syntax_error", 1); formal->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, reason ? reason : "syntax_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name ? pred_name : "predicate", pred_arity); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } typedef void (*pl_on_solution_fn)(const pl_env *env, void *ctx); typedef struct { const pl_env *env; } pl_once_ctx; static void once_on_solution(const pl_env *env, void *ctx0) { pl_once_ctx *ctx = (pl_once_ctx *)ctx0; if (!ctx || ctx->env) { return; } ctx->env = env; } /* ============================================================================ * SECTION 20: Tabling * call-by-variant tabling and TC fast-paths. * ============================================================================ */ /* --- SUBSECTION 20.1: Table State & Hashing ------------------------------ */ // Tabling state and hash helpers. // table_var_id_map_init()/table_var_id_for() map vars; table_hash_term_variant_tr() hashes variant terms for subgoals. typedef struct { pl_var_key key; uint64_t id; } pl_table_var_id_entry; typedef struct { pl_table_var_id_entry *items; ULO count; ULO cap; uint64_t next_id; } pl_table_var_id_map; static void table_var_id_map_init(pl_table_var_id_map *m) { memset(m, 0, sizeof(*m)); } static void table_var_id_map_free(pl_table_var_id_map *m) { free(m->items); memset(m, 0, sizeof(*m)); } static uint64_t table_var_id_for(pl_table_var_id_map *m, const ULO *dbg_dat_ptr, pl_var_key k) { if (!m) { return 0; } for (ULO i = 0; i < m->count; i++) { if (var_key_eq(m->items[i].key, k)) { return m->items[i].id; } } if (m->count == m->cap) { ULO new_cap = m->cap ? (m->cap * 2) : 32; pl_table_var_id_entry *new_items = (pl_table_var_id_entry *)realloc(m->items, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } m->items = new_items; m->cap = new_cap; } const uint64_t id = ++m->next_id; m->items[m->count++] = (pl_table_var_id_entry){.key = k, .id = id}; return id; } static uint64_t table_hash_term_variant_tr(pl_term *t, pl_table_var_id_map *m, const ULO *dbg_dat_ptr, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return hash_mix64(0xC0FFEEULL); } t = (pl_term *)term_peel_pstr_empty_const(t); if (!t) { return hash_mix64(0xC0FFEEULL); } const unsigned char *pbytes = NULL; ULO len_bytes = 0; const pl_term *tail_term = NULL; if (term_pstr_run_bytes_len_tail_const(t, &pbytes, &len_bytes, &tail_term)) { // List-equivalent: hash as nested '.'/2 terms. uint64_t tail = tail_term ? table_hash_term_variant_tr((pl_term *)tail_term, m, dbg_dat_ptr, depth + 1) : hash_mix64(0xA01ULL ^ hash_cstr("[]")); const uint64_t dot_hash = hash_cstr("."); const uint64_t ar2_hash = hash_mix64(2ULL); const uint64_t c = 0x9e3779b97f4a7c15ULL; ULO cp_len = 0; uint32_t *codepoints = pstr_decode_run_codepoints(pbytes, (size_t)len_bytes, &cp_len, dbg_dat_ptr); for (ULO i = cp_len; i > 0; i--) { const uint32_t ch = codepoints[i - 1]; CHR tmp[PL_UTF8_MAX_BYTES + 1] = {0}; const size_t n = utf8_encode_one(ch, (unsigned char *)tmp, PL_UTF8_MAX_BYTES); tmp[n] = 0; const uint64_t head = hash_mix64(0xA01ULL ^ hash_cstr(tmp)); uint64_t h = hash_mix64(0x537ULL); h ^= dot_hash; h ^= ar2_hash; h ^= hash_mix64(head + c + 0ULL); h ^= hash_mix64(tail + c + 1ULL); tail = hash_mix64(h); } free(codepoints); return tail; } if (term_is_pstr(t)) { return hash_mix64(0xA01ULL ^ hash_cstr("[]")); } switch (t->tag) { case PL_TERM_ATOM: return hash_mix64(0xA01ULL ^ hash_cstr(t->v.atom_name)); case PL_TERM_INT: return hash_mix64(0x1A7ULL ^ (uint64_t)t->v.int_value); case PL_TERM_BIGINT: { if (!t->v.bigint) { return hash_mix64(0x1A7ULL); } SLO v = 0; if (bigint_fits_slo(t->v.bigint, &v)) { return hash_mix64(0x1A7ULL ^ (uint64_t)v); } const pl_bigint *b = t->v.bigint; uint64_t h = hash_mix64(0xB16B00B5ULL ^ (uint64_t)b->sign); for (ULO i = 0; i < b->len; i++) { h ^= hash_mix64((uint64_t)b->limbs[i] + 0x9e3779b97f4a7c15ULL + (uint64_t)i); } return hash_mix64(h); } case PL_TERM_FLOAT: { uint64_t bits = 0; memcpy(&bits, &t->v.float_value, sizeof(bits)); return hash_mix64(0xF10A7ULL ^ bits); } case PL_TERM_VAR: { pl_var_key k = {.scope = t->v.var.scope, .var_id = t->v.var.var_id}; const uint64_t id = table_var_id_for(m, dbg_dat_ptr, k); return hash_mix64(0x5A7ULL ^ id); } case PL_TERM_STRUCT: { uint64_t h = hash_mix64(0x537ULL); h ^= hash_cstr(t->v.str.functor); h ^= hash_mix64((uint64_t)t->v.str.arity); for (ULO i = 0; i < t->v.str.arity; i++) { const uint64_t ah = table_hash_term_variant_tr(t->v.str.args[i], m, dbg_dat_ptr, depth + 1); h ^= hash_mix64(ah + 0x9e3779b97f4a7c15ULL + (uint64_t)i); } return hash_mix64(h); } default: break; } return hash_mix64(0xBADULL); } static uint64_t table_hash_term_variant(pl_term *t, const ULO *dbg_dat_ptr) { pl_table_var_id_map m; table_var_id_map_init(&m); const uint64_t h = table_hash_term_variant_tr(t, &m, dbg_dat_ptr, 0); table_var_id_map_free(&m); return h; } typedef struct pl_tc_work { ULO node_count; ULO queue_cap; ULO start_id; ULO worker_count; // Adjacency list (1-based node ids). const ULO *adj_offs; // length node_count+2; offs[id]..offs[id+1] const ULO *adj_to; // length edge_count atomic_ulong head; // next queue index to claim (0-based) atomic_ulong tail; // next free queue slot (reserved count; 0..queue_cap) atomic_int inflight; atomic_int has_cycle; // 1 if start is reachable via >=1 edge atomic_int done; atomic_int cancel; atomic_ulong cp_mask; // bitset of CPUPROC ids (mod 64) that participated atomic_uchar *visited; // length node_count+1 (1-based ids) atomic_uchar *ready; // length queue_cap (0..queue_cap-1) ULO *queue; // length queue_cap (0..queue_cap-1) } pl_tc_work; static void pl_tc_worker_run(pl_tc_work *work) { if (!work || !work->queue || !work->ready || !work->visited || !work->adj_offs || !work->adj_to || !work->queue_cap || !work->node_count || !work->start_id) { if (work) { (void)atomic_fetch_add_explicit(&work->done, 1, memory_order_acq_rel); } return; } for (;;) { if (atomic_load_explicit(&work->cancel, memory_order_acquire)) { break; } unsigned long h = atomic_load_explicit(&work->head, memory_order_acquire); const unsigned long t = atomic_load_explicit(&work->tail, memory_order_acquire); if (h >= t) { if (atomic_load_explicit(&work->inflight, memory_order_acquire) == 0) { break; } usleep(1000); continue; } // Claim one queue index (do not let head overshoot tail). if (!atomic_compare_exchange_weak_explicit(&work->head, &h, h + 1, memory_order_acq_rel, memory_order_acquire)) { continue; } (void)atomic_fetch_add_explicit(&work->inflight, 1, memory_order_acq_rel); // Wait until the producer has stored the node id. while (!atomic_load_explicit(&work->ready[h], memory_order_acquire)) { if (atomic_load_explicit(&work->cancel, memory_order_acquire)) { break; } usleep(1000); } if (atomic_load_explicit(&work->cancel, memory_order_acquire)) { (void)atomic_fetch_sub_explicit(&work->inflight, 1, memory_order_acq_rel); break; } const ULO node_id = work->queue[h]; if (node_id >= 1 && node_id <= work->node_count) { const ULO start = work->adj_offs[node_id]; const ULO end = work->adj_offs[node_id + 1]; for (ULO i = start; i < end; i++) { if (atomic_load_explicit(&work->cancel, memory_order_acquire)) { break; } const ULO cand = work->adj_to[i]; if (!cand || cand > work->node_count) { continue; } if (cand == work->start_id) { atomic_store_explicit(&work->has_cycle, 1, memory_order_release); continue; } unsigned char expected = 0; if (!atomic_compare_exchange_strong_explicit(&work->visited[cand], &expected, 1, memory_order_acq_rel, memory_order_acquire)) { continue; } const unsigned long idx = atomic_fetch_add_explicit(&work->tail, 1, memory_order_acq_rel); if (idx >= work->queue_cap) { atomic_store_explicit(&work->cancel, 1, memory_order_release); break; } work->queue[idx] = cand; atomic_store_explicit(&work->ready[idx], 1, memory_order_release); } } (void)atomic_fetch_sub_explicit(&work->inflight, 1, memory_order_acq_rel); } (void)atomic_fetch_add_explicit(&work->done, 1, memory_order_acq_rel); } typedef struct { pl_tc_work *work; } pl_tc_thread_ctx; static void *pl_tc_thread_main(void *arg) { pl_tc_thread_ctx *ctx = (pl_tc_thread_ctx *)arg; if (!ctx || !ctx->work) { return NULL; } flowlog_cstack_init_once(); #if defined(SIGSEGV) flowlog_install_sigsegv_trace_handler(atomic_load_explicit(&g_sigsegv_trace_enabled, memory_order_relaxed)); #endif pl_tc_worker_run(ctx->work); return NULL; } static bool term_is_ground_in_env(pl_term *t, const pl_env *env, const ULO *dbg_dat_ptr) { if (!t) { return false; } pl_var_stack st; var_stack_init(&st); const bool ok = term_is_ground_tr(t, env, &st, dbg_dat_ptr, 0); var_stack_free(&st); return ok; } static uint64_t term_hash_ground_tr(const pl_term *t, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return hash_mix64(0xC0FFEEULL); } t = term_peel_pstr_empty_const(t); if (!t) { return hash_mix64(0xC0FFEEULL); } const unsigned char *pbytes = NULL; ULO len_bytes = 0; const pl_term *tail_term = NULL; if (term_pstr_run_bytes_len_tail_const(t, &pbytes, &len_bytes, &tail_term)) { uint64_t tail = tail_term ? term_hash_ground_tr(tail_term, depth + 1) : hash_mix64(0xA01ULL ^ hash_cstr("[]")); const uint64_t dot_hash = hash_cstr("."); const uint64_t ar2_hash = hash_mix64(2ULL); const uint64_t c = 0x9e3779b97f4a7c15ULL; ULO cp_len = 0; uint32_t *codepoints = pstr_decode_run_codepoints(pbytes, (size_t)len_bytes, &cp_len, NULL); for (ULO i = cp_len; i > 0; i--) { const uint32_t ch = codepoints[i - 1]; CHR tmp[PL_UTF8_MAX_BYTES + 1] = {0}; const size_t n = utf8_encode_one(ch, (unsigned char *)tmp, PL_UTF8_MAX_BYTES); tmp[n] = 0; const uint64_t head = hash_mix64(0xA01ULL ^ hash_cstr(tmp)); uint64_t h = hash_mix64(0x537ULL); h ^= dot_hash; h ^= ar2_hash; h ^= hash_mix64(head + c + 0ULL); h ^= hash_mix64(tail + c + 1ULL); tail = hash_mix64(h); } free(codepoints); return tail; } if (term_is_pstr(t)) { return hash_mix64(0xA01ULL ^ hash_cstr("[]")); } switch (t->tag) { case PL_TERM_ATOM: return hash_mix64(0xA01ULL ^ hash_cstr(t->v.atom_name)); case PL_TERM_INT: return hash_mix64(0x1A7ULL ^ (uint64_t)t->v.int_value); case PL_TERM_BIGINT: { if (!t->v.bigint) { return hash_mix64(0x1A7ULL); } SLO v = 0; if (bigint_fits_slo(t->v.bigint, &v)) { return hash_mix64(0x1A7ULL ^ (uint64_t)v); } const pl_bigint *b = t->v.bigint; uint64_t h = hash_mix64(0xB16B00B5ULL ^ (uint64_t)b->sign); for (ULO i = 0; i < b->len; i++) { h ^= hash_mix64((uint64_t)b->limbs[i] + 0x9e3779b97f4a7c15ULL + (uint64_t)i); } return hash_mix64(h); } case PL_TERM_FLOAT: { uint64_t bits = 0; memcpy(&bits, &t->v.float_value, sizeof(bits)); return hash_mix64(0xF10A7ULL ^ bits); } case PL_TERM_VAR: { const uint64_t s = (uint64_t)(uintptr_t)t->v.var.scope; const uint64_t v = (uint64_t)t->v.var.var_id; return hash_mix64(0x5A7ULL ^ hash_mix64(s) ^ hash_mix64(v)); } case PL_TERM_STRUCT: { uint64_t h = hash_mix64(0x537ULL); h ^= hash_cstr(t->v.str.functor); h ^= hash_mix64((uint64_t)t->v.str.arity); for (ULO i = 0; i < t->v.str.arity; i++) { const uint64_t ah = term_hash_ground_tr(t->v.str.args[i], depth + 1); h ^= hash_mix64(ah + 0x9e3779b97f4a7c15ULL + (uint64_t)i); } return hash_mix64(h); } default: break; } return hash_mix64(0xBADULL); } static uint64_t term_hash_ground(const pl_term *t) { return term_hash_ground_tr(t, 0); } typedef struct { const pl_term *term; uint64_t hash; } pl_node_entry; typedef struct { pl_node_entry *items; // index = id-1 ULO count; ULO cap; ULO *slots; // open-addressed item indices (+1); 0 means empty ULO slot_cap; // power-of-two } pl_node_map; static void node_map_init(pl_node_map *m) { memset(m, 0, sizeof(*m)); } static void node_map_free(pl_node_map *m) { if (!m) { return; } free(m->items); free(m->slots); memset(m, 0, sizeof(*m)); } static void node_map_rehash(pl_node_map *m, const ULO *dbg_dat_ptr, ULO want_cap) { if (!m) { return; } if (want_cap < 64) { want_cap = 64; } ULO cap = 1; while (cap < want_cap) { cap <<= 1; } ULO *slots = (ULO *)calloc(cap, sizeof(*slots)); if (!slots) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } const ULO mask = cap - 1; for (ULO i = 0; i < m->count; i++) { const uint64_t h = m->items[i].hash; ULO pos = (ULO)(h & (uint64_t)mask); for (ULO guard = 0; guard < cap; guard++) { if (!slots[pos]) { slots[pos] = i + 1; break; } pos = (pos + 1) & mask; } } free(m->slots); m->slots = slots; m->slot_cap = cap; } static void node_map_maybe_grow(pl_node_map *m, const ULO *dbg_dat_ptr) { if (!m) { return; } if (!m->slots || !m->slot_cap) { node_map_rehash(m, dbg_dat_ptr, 64); return; } // Grow at ~70% load factor. if ((m->count + 1) * 10 < m->slot_cap * 7) { return; } node_map_rehash(m, dbg_dat_ptr, m->slot_cap ? (m->slot_cap * 2) : 64); } static ULO node_map_lookup(const pl_node_map *m, const pl_term *t, uint64_t h) { if (!m || !t || !m->slots || !m->slot_cap) { return 0; } const ULO mask = m->slot_cap - 1; ULO pos = (ULO)(h & (uint64_t)mask); for (ULO guard = 0; guard < m->slot_cap; guard++) { const ULO idx1 = m->slots[pos]; if (!idx1) { return 0; } const ULO ei = idx1 - 1; if (ei < m->count) { const pl_node_entry *e = &m->items[ei]; if (e->hash == h && e->term && term_equal((pl_term *)e->term, (pl_term *)t)) { return ei + 1; } } pos = (pos + 1) & mask; } return 0; } static ULO node_map_intern(pl_node_map *m, const pl_term *t, const ULO *dbg_dat_ptr) { if (!m || !t) { return 0; } node_map_maybe_grow(m, dbg_dat_ptr); const uint64_t h = term_hash_ground(t); ULO found = node_map_lookup(m, t, h); if (found) { return found; } if (m->count == m->cap) { ULO new_cap = m->cap ? (m->cap * 2) : 64; pl_node_entry *new_items = (pl_node_entry *)realloc(m->items, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } m->items = new_items; m->cap = new_cap; } const ULO id = ++m->count; // 1-based id m->items[id - 1] = (pl_node_entry){.term = t, .hash = h}; const ULO mask = m->slot_cap - 1; ULO pos = (ULO)(h & (uint64_t)mask); for (ULO guard = 0; guard < m->slot_cap; guard++) { if (!m->slots[pos]) { m->slots[pos] = id; return id; } pos = (pos + 1) & mask; } rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: node table overflow", dbg_dat_ptr); return 0; } typedef struct { ULO *from; ULO *to; ULO count; ULO cap; } pl_edge_vec; static void edge_vec_free(pl_edge_vec *v) { if (!v) { return; } free(v->from); free(v->to); memset(v, 0, sizeof(*v)); } static void edge_vec_push(pl_edge_vec *v, const ULO *dbg_dat_ptr, ULO a, ULO b) { if (!v) { return; } if (v->count == v->cap) { ULO new_cap = v->cap ? (v->cap * 2) : 128; ULO *nf = (ULO *)realloc(v->from, sizeof(*nf) * new_cap); ULO *nt = (ULO *)realloc(v->to, sizeof(*nt) * new_cap); if (!nf || !nt) { free(nf); free(nt); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } v->from = nf; v->to = nt; v->cap = new_cap; } v->from[v->count] = a; v->to[v->count] = b; v->count++; } static bool table_subgoal_add_answer(pl_tabled_subgoal *sg, pl_term *call_goal, const pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr); static void flowlog_wait_done(const atomic_int *done, int expected); static bool table_try_tc_fastpath(pl_program *prog, pl_term *goal, const pl_env *env_in, pl_tabled_subgoal *sg, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !goal || !env_in || !sg || !g_table_state) { return false; } if (goal->tag != PL_TERM_STRUCT || goal->v.str.arity != 2 || !goal->v.str.functor || !goal->v.str.args) { return false; } // Only right-linear Pred/2 transitive closure: Pred(X,Y) :- Base(X,Y). Pred(X,Y) :- Base(X,Z), Pred(Z,Y). const CHR *pred = goal->v.str.functor; // First argument must be ground (after applying the current environment). if (!term_is_ground_in_env(goal->v.str.args[0], env_in, dbg_dat_ptr)) { return false; } pl_term *start_t = deref_term(goal->v.str.args[0], env_in); if (!start_t) { return false; } // Second argument must be a variable or ground (after applying env). pl_term *out_d = deref_term(goal->v.str.args[1], env_in); if (!out_d) { return false; } const bool out_is_var = (out_d->tag == PL_TERM_VAR); if (!out_is_var && !term_is_ground_in_env(goal->v.str.args[1], env_in, dbg_dat_ptr)) { return false; } // Fetch all clauses for Pred/2 (avoid filtering by argument bindings). pl_scope *dummy_scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*dummy_scope), dbg_dat_ptr); pl_term *dummy_goal = make_struct_shallow_rt(rt_ctrl, dbg_dat_ptr, pred, 2); dummy_goal->v.str.args[0] = make_var_rt(rt_ctrl, dbg_dat_ptr, dummy_scope, 0, "A"); dummy_goal->v.str.args[1] = make_var_rt(rt_ctrl, dbg_dat_ptr, dummy_scope, 1, "B"); pl_env dummy_env = {0}; ULO pred_count = 0; const pl_clause **pred_clauses = prog_snapshot_pred_cands(prog, pred, 2, dummy_goal, &dummy_env, &pred_count, rt_ctrl, dbg_dat_ptr); if (!pred_clauses || pred_count != 2) { return false; } const pl_clause *base_cl = NULL; const pl_clause *rec_cl = NULL; for (ULO i = 0; i < pred_count; i++) { const pl_clause *cl = pred_clauses[i]; if (!cl || !cl->head) { return false; } if (cl->body_count == 1) { if (base_cl) { return false; } base_cl = cl; } else if (cl->body_count == 2) { if (rec_cl) { return false; } rec_cl = cl; } else { return false; } } if (!base_cl || !rec_cl) { return false; } // Analyze base clause: Pred(X,Y) :- Base(X,Y). const pl_term *bh = base_cl->head; if (!bh || bh->tag != PL_TERM_STRUCT || bh->v.str.arity != 2 || !bh->v.str.functor || strcmp(bh->v.str.functor, pred)) { return false; } const pl_term *b_x = bh->v.str.args ? bh->v.str.args[0] : NULL; const pl_term *b_y = bh->v.str.args ? bh->v.str.args[1] : NULL; if (!b_x || !b_y || b_x->tag != PL_TERM_VAR || b_y->tag != PL_TERM_VAR) { return false; } const ULO bx = b_x->v.var.var_id; const ULO by = b_y->v.var.var_id; const pl_term *bgoal = (base_cl->body && base_cl->body_count) ? base_cl->body[1] : NULL; if (!bgoal || bgoal->tag != PL_TERM_STRUCT || bgoal->v.str.arity != 2 || !bgoal->v.str.functor || !bgoal->v.str.args) { return false; } const CHR *base_pred = bgoal->v.str.functor; const pl_term *bga = bgoal->v.str.args[0]; const pl_term *bgb = bgoal->v.str.args[1]; if (!bga || !bgb || bga->tag != PL_TERM_VAR || bgb->tag != PL_TERM_VAR || bga->v.var.var_id != bx || bgb->v.var.var_id != by) { return false; } // Analyze recursive clause: Pred(X,Y) :- Base(X,Z), Pred(Z,Y). const pl_term *rh = rec_cl->head; if (!rh || rh->tag != PL_TERM_STRUCT || rh->v.str.arity != 2 || !rh->v.str.functor || strcmp(rh->v.str.functor, pred)) { return false; } const pl_term *r_x = rh->v.str.args ? rh->v.str.args[0] : NULL; const pl_term *r_y = rh->v.str.args ? rh->v.str.args[1] : NULL; if (!r_x || !r_y || r_x->tag != PL_TERM_VAR || r_y->tag != PL_TERM_VAR) { return false; } const ULO rx = r_x->v.var.var_id; const ULO ry = r_y->v.var.var_id; const pl_term *r1 = (rec_cl->body && rec_cl->body_count >= 1) ? rec_cl->body[1] : NULL; const pl_term *r2 = (rec_cl->body && rec_cl->body_count >= 2) ? rec_cl->body[2] : NULL; if (!r1 || !r2 || r1->tag != PL_TERM_STRUCT || r1->v.str.arity != 2 || !r1->v.str.functor || !r1->v.str.args || r2->tag != PL_TERM_STRUCT || r2->v.str.arity != 2 || !r2->v.str.functor || !r2->v.str.args) { return false; } if (strcmp(r1->v.str.functor, base_pred) || strcmp(r2->v.str.functor, pred)) { return false; } const pl_term *r1a = r1->v.str.args[0]; const pl_term *r1b = r1->v.str.args[1]; const pl_term *r2a = r2->v.str.args[0]; const pl_term *r2b = r2->v.str.args[1]; if (!r1a || !r1b || !r2a || !r2b || r1a->tag != PL_TERM_VAR || r1b->tag != PL_TERM_VAR || r2a->tag != PL_TERM_VAR || r2b->tag != PL_TERM_VAR) { return false; } const ULO rz = r1b->v.var.var_id; if (r1a->v.var.var_id != rx || r2a->v.var.var_id != rz || r2b->v.var.var_id != ry) { return false; } // Fetch Base/2 facts (must be facts-only). pl_scope *base_scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*base_scope), dbg_dat_ptr); pl_term *base_goal = make_struct_shallow_rt(rt_ctrl, dbg_dat_ptr, base_pred, 2); base_goal->v.str.args[0] = make_var_rt(rt_ctrl, dbg_dat_ptr, base_scope, 0, "X"); base_goal->v.str.args[1] = make_var_rt(rt_ctrl, dbg_dat_ptr, base_scope, 1, "Y"); ULO base_count = 0; const pl_clause **base_clauses = prog_snapshot_pred_cands(prog, base_pred, 2, base_goal, &dummy_env, &base_count, rt_ctrl, dbg_dat_ptr); if (!base_clauses) { base_count = 0; } for (ULO i = 0; i < base_count; i++) { const pl_clause *cl = base_clauses[i]; if (!cl || !cl->head) { continue; } if (cl->body_count) { return false; } if (cl->env) { return false; } } // Build node ids + edge list. pl_node_map nodes; node_map_init(&nodes); pl_edge_vec edges = {0}; const ULO start_id = node_map_intern(&nodes, start_t, dbg_dat_ptr); if (!start_id) { node_map_free(&nodes); return false; } for (ULO i = 0; i < base_count; i++) { const pl_clause *cl = base_clauses[i]; if (!cl || !cl->head || cl->body_count) { continue; } const pl_term *h = cl->head; if (!h || h->tag != PL_TERM_STRUCT || h->v.str.arity != 2 || !h->v.str.functor || strcmp(h->v.str.functor, base_pred) || !h->v.str.args) { continue; } const pl_term *a = h->v.str.args[0]; const pl_term *b = h->v.str.args[1]; if (!a || !b) { continue; } if (!term_is_ground_in_env((pl_term *)a, NULL, dbg_dat_ptr) || !term_is_ground_in_env((pl_term *)b, NULL, dbg_dat_ptr)) { edge_vec_free(&edges); node_map_free(&nodes); return false; } const ULO ai = node_map_intern(&nodes, a, dbg_dat_ptr); const ULO bi = node_map_intern(&nodes, b, dbg_dat_ptr); if (!ai || !bi) { edge_vec_free(&edges); node_map_free(&nodes); return false; } edge_vec_push(&edges, dbg_dat_ptr, ai, bi); } const ULO node_count = nodes.count; if (!node_count) { edge_vec_free(&edges); node_map_free(&nodes); return false; } // No edges => no solutions for Pred/2 (except cycles, which cannot exist with zero edges). if (!edges.count) { edge_vec_free(&edges); node_map_free(&nodes); return true; } // Build adjacency list in shared memory so CPUPROCs can traverse it. ULO *deg = (ULO *)calloc(node_count + 1, sizeof(*deg)); if (!deg) { edge_vec_free(&edges); node_map_free(&nodes); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < edges.count; i++) { const ULO from = edges.from[i]; if (from >= 1 && from <= node_count) { deg[from]++; } } const ULO edge_count = edges.count; ULO *adj_offs = (ULO *)pool_alloc(rt_ctrl, sizeof(*adj_offs) * (node_count + 2), dbg_dat_ptr); ULO *adj_to = (ULO *)pool_alloc(rt_ctrl, sizeof(*adj_to) * edge_count, dbg_dat_ptr); adj_offs[0] = 0; adj_offs[1] = 0; for (ULO id = 1; id <= node_count; id++) { adj_offs[id + 1] = adj_offs[id] + deg[id]; } if (adj_offs[node_count + 1] != edge_count) { free(deg); edge_vec_free(&edges); node_map_free(&nodes); return false; } ULO *cur = (ULO *)malloc(sizeof(*cur) * (node_count + 2)); if (!cur) { free(deg); edge_vec_free(&edges); node_map_free(&nodes); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(cur, adj_offs, sizeof(*cur) * (node_count + 2)); for (ULO i = 0; i < edges.count; i++) { const ULO from = edges.from[i]; const ULO to = edges.to[i]; if (from < 1 || from > node_count) { continue; } ULO pos = cur[from]++; if (pos < edge_count) { adj_to[pos] = to; } } free(cur); free(deg); // Allocate shared work state. const ULO queue_cap = node_count; pl_tc_work *work = (pl_tc_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->node_count = node_count; work->queue_cap = queue_cap; work->start_id = start_id; work->adj_offs = adj_offs; work->adj_to = adj_to; atomic_init(&work->head, 0); atomic_init(&work->tail, 1); atomic_init(&work->inflight, 0); atomic_init(&work->has_cycle, 0); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); atomic_init(&work->cp_mask, 0); work->visited = (atomic_uchar *)pool_alloc(rt_ctrl, sizeof(*work->visited) * (node_count + 1), dbg_dat_ptr); work->ready = (atomic_uchar *)pool_alloc(rt_ctrl, sizeof(*work->ready) * queue_cap, dbg_dat_ptr); work->queue = (ULO *)pool_alloc(rt_ctrl, sizeof(*work->queue) * queue_cap, dbg_dat_ptr); memset((void *)work->visited, 0, sizeof(*work->visited) * (node_count + 1)); memset((void *)work->ready, 0, sizeof(*work->ready) * queue_cap); memset((void *)work->queue, 0, sizeof(*work->queue) * queue_cap); atomic_store_explicit(&work->visited[start_id], 1, memory_order_release); work->queue[0] = start_id; atomic_store_explicit(&work->ready[0], 1, memory_order_release); // Choose worker count (CPUPROC tasks) and coordinate with the global query budget. ULO worker_count = (ULO)get_n_cpuproc(); if (worker_count < 1) { worker_count = 1; } if (worker_count > node_count) { worker_count = node_count; } if (worker_count < 1) { worker_count = 1; } int remote_taken = 0; if (g_par_budget && worker_count > 1) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } work->worker_count = worker_count; g_last_tc_start_ok = 0; g_last_tc_start_err_code = 0; g_last_tc_start_err_text[0] = '\0'; const SLO cp_local = (SLO)get_id_cpuproc_fast(rt_ctrl); if (cp_local >= 0) { const unsigned shift = (unsigned)(((unsigned long long)cp_local) & 63ull); (void)atomic_fetch_or_explicit(&work->cp_mask, (unsigned long)(1ull << shift), memory_order_acq_rel); } bool ran_local = false; ULO created = 0; if (worker_count > 1) { const ULO spawn_n = worker_count - 1; pthread_t *threads = (pthread_t *)calloc(spawn_n, sizeof(*threads)); pl_tc_thread_ctx *ctx = (pl_tc_thread_ctx *)calloc(spawn_n, sizeof(*ctx)); if (threads && ctx) { for (; created < spawn_n; created++) { ctx[created] = (pl_tc_thread_ctx){.work = work}; if (pthread_create(&threads[created], NULL, pl_tc_thread_main, &ctx[created]) != 0) { break; } } ran_local = true; pl_tc_worker_run(work); for (ULO i = 0; i < created; i++) { (void)pthread_join(threads[i], NULL); } } free(ctx); free(threads); } if (!ran_local) { pl_tc_worker_run(work); } const bool ran_parallel = (created > 0); worker_count = 1 + created; work->worker_count = worker_count; g_last_tc_start_ok = ran_parallel ? 1 : 0; g_last_tc_worker_count = worker_count; if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } g_last_tc_cp_mask = (uint64_t)atomic_load_explicit(&work->cp_mask, memory_order_acquire); g_last_tc_worker_count = worker_count; const bool has_cycle = atomic_load_explicit(&work->has_cycle, memory_order_acquire) != 0; const bool cancelled = atomic_load_explicit(&work->cancel, memory_order_acquire) != 0; if (cancelled) { edge_vec_free(&edges); node_map_free(&nodes); return false; } // Ground output check: succeed iff the target node is reachable (taking cycle semantics into account). if (!out_is_var) { bool ok = false; if (term_equal(start_t, out_d)) { ok = has_cycle; } else { const uint64_t oh = term_hash_ground(out_d); const ULO out_id = node_map_lookup(&nodes, out_d, oh); if (out_id >= 1 && out_id <= node_count) { ok = atomic_load_explicit(&work->visited[out_id], memory_order_acquire) != 0; } } if (ok) { (void)table_subgoal_add_answer(sg, goal, env_in, rt_ctrl, dbg_dat_ptr); } edge_vec_free(&edges); node_map_free(&nodes); return true; } // Collect reachable nodes (unique), sort in standard term order for determinism, then add table answers. pl_term **reached = NULL; ULO reached_count = 0; ULO reached_cap = 0; for (ULO id = 1; id <= node_count; id++) { if (id == start_id) { if (!has_cycle) { continue; } } else { if (!atomic_load_explicit(&work->visited[id], memory_order_acquire)) { continue; } } if (reached_count == reached_cap) { ULO new_cap = reached_cap ? (reached_cap * 2) : 64; pl_term **new_items = (pl_term **)realloc(reached, sizeof(*new_items) * new_cap); if (!new_items) { free(reached); edge_vec_free(&edges); node_map_free(&nodes); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } reached = new_items; reached_cap = new_cap; } reached[reached_count++] = (pl_term *)nodes.items[id - 1].term; } if (reached_count) { const pl_env *saved_env = g_qsort_env; const ULO *saved_dbg = g_qsort_dbg_dat_ptr; g_qsort_env = NULL; g_qsort_dbg_dat_ptr = dbg_dat_ptr; qsort(reached, (size_t)reached_count, sizeof(pl_term *), qsort_pl_term_ptr_cmp); g_qsort_env = saved_env; g_qsort_dbg_dat_ptr = saved_dbg; } pl_env *env_base = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const ULO base_count0 = env_base ? env_base->count : 0; for (ULO i = 0; i < reached_count; i++) { if (!env_base) { break; } env_base->count = base_count0; env_bind(env_base, rt_ctrl, dbg_dat_ptr, out_d->v.var.scope, out_d->v.var.var_id, reached[i]); (void)table_subgoal_add_answer(sg, goal, env_base, rt_ctrl, dbg_dat_ptr); } free(reached); edge_vec_free(&edges); node_map_free(&nodes); return true; } typedef struct pl_tabled_subgoal { pl_term *key; // canonical call key (frozen term copy; no env needed) uint64_t hash; bool evaluating; bool complete; bool new_answer; ULO stack_index; // 0-based index while on the evaluation stack, else ~0 struct pl_tabled_subgoal *leader; // SCC leader while evaluating pl_term **answers; // stored as terms shaped like the call itself ULO answer_count; ULO answer_cap; } pl_tabled_subgoal; struct pl_table_state { pl_tabled_subgoal **subs; ULO sub_count; ULO sub_cap; ULO *slots; // open-addressed hash table of subgoal indices (+1), 0 means empty ULO slot_cap; // power-of-two pl_tabled_subgoal **stack; // active generator stack (0-based) ULO stack_count; ULO stack_cap; pl_tabled_subgoal *current; // currently executing generator (call stack), may differ from stack top // Separate temp allocator for table keys/answers (must survive temp releases during search). pl_temp_alloc alloc; }; static pl_table_state *table_state_create(const ULO *dbg_dat_ptr) { pl_table_state *st = (pl_table_state *)calloc(1, sizeof(*st)); if (!st) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } st->slot_cap = 64; st->slots = (ULO *)calloc(st->slot_cap, sizeof(ULO)); if (!st->slots) { free(st); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } return st; } static void table_state_free(pl_table_state *st, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!st) { return; } if (st->subs) { for (ULO i = 0; i < st->sub_count; i++) { pl_tabled_subgoal *sg = st->subs[i]; if (!sg) { continue; } free(sg->answers); free(sg); } } free(st->subs); free(st->slots); free(st->stack); temp_alloc_free_all(&st->alloc, rt_ctrl, dbg_dat_ptr); free(st); } static void table_state_rehash(pl_table_state *st, const ULO *dbg_dat_ptr, ULO new_cap) { if (!st) { return; } if (new_cap < 64) { new_cap = 64; } // Ensure power-of-two. ULO cap = 1; while (cap < new_cap) { cap <<= 1; } ULO *new_slots = (ULO *)calloc(cap, sizeof(ULO)); if (!new_slots) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } const ULO mask = cap - 1; for (ULO i = 0; i < st->sub_count; i++) { const pl_tabled_subgoal *sg = st->subs[i]; if (!sg) { continue; } ULO pos = (ULO)(sg->hash & (uint64_t)mask); for (ULO guard = 0; guard < cap; guard++) { if (!new_slots[pos]) { new_slots[pos] = i + 1; break; } pos = (pos + 1) & mask; } } free(st->slots); st->slots = new_slots; st->slot_cap = cap; } static void table_state_maybe_grow(pl_table_state *st, const ULO *dbg_dat_ptr) { if (!st) { return; } // Grow at ~70% load factor. if ((st->sub_count + 1) * 10 < st->slot_cap * 7) { return; } table_state_rehash(st, dbg_dat_ptr, st->slot_cap ? (st->slot_cap * 2) : 64); } static pl_tabled_subgoal *table_state_lookup(pl_table_state *st, pl_term *key, uint64_t hash, const ULO *dbg_dat_ptr) { if (!st || !st->slots || !st->slot_cap || !key) { return NULL; } const ULO mask = st->slot_cap - 1; ULO pos = (ULO)(hash & (uint64_t)mask); for (ULO guard = 0; guard < st->slot_cap; guard++) { const ULO idx1 = st->slots[pos]; if (!idx1) { return NULL; } pl_tabled_subgoal *sg = st->subs[idx1 - 1]; if (sg && sg->hash == hash && term_variant_env(key, sg->key, NULL, dbg_dat_ptr)) { return sg; } pos = (pos + 1) & mask; } return NULL; } static pl_tabled_subgoal *table_state_insert(pl_table_state *st, pl_term *key_persist, uint64_t hash, const ULO *dbg_dat_ptr) { if (!st || !key_persist) { return NULL; } table_state_maybe_grow(st, dbg_dat_ptr); if (st->sub_count == st->sub_cap) { ULO new_cap = st->sub_cap ? (st->sub_cap * 2) : 16; pl_tabled_subgoal **new_subs = (pl_tabled_subgoal **)realloc(st->subs, sizeof(*new_subs) * new_cap); if (!new_subs) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } st->subs = new_subs; st->sub_cap = new_cap; } pl_tabled_subgoal *sg = (pl_tabled_subgoal *)calloc(1, sizeof(*sg)); if (!sg) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } sg->key = key_persist; sg->hash = hash; sg->evaluating = false; sg->complete = false; sg->new_answer = false; sg->stack_index = (ULO)~(ULO)0; sg->leader = sg; st->subs[st->sub_count] = sg; const ULO new_idx = st->sub_count++; const ULO mask = st->slot_cap - 1; ULO pos = (ULO)(hash & (uint64_t)mask); for (ULO guard = 0; guard < st->slot_cap; guard++) { if (!st->slots[pos]) { st->slots[pos] = new_idx + 1; return sg; } pos = (pos + 1) & mask; } // Should not happen (rehash should ensure spare capacity). rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: table overflow", dbg_dat_ptr); return NULL; } /* --- SUBSECTION 20.2: Interpreter Tabling Runtime ------------------------ */ // Interpreter tabling runtime. // table_stack_push()/table_stack_pop_to() manage SCC stacks; table_scc_merge() completes SCCs. static pl_cut_signal solve_goals_cb(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, pl_on_solution_fn on_solution, void *on_solution_ctx, const void *rt_ctrl, const ULO *dbg_dat_ptr); static void table_stack_ensure_cap(pl_table_state *st, const ULO *dbg_dat_ptr, ULO want) { if (!st) { return; } if (want < 1) { want = 1; } if (st->stack_cap >= want) { return; } ULO new_cap = st->stack_cap ? st->stack_cap : 16; while (new_cap < want) { new_cap *= 2; } pl_tabled_subgoal **new_stack = (pl_tabled_subgoal **)realloc(st->stack, sizeof(*new_stack) * new_cap); if (!new_stack) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } st->stack = new_stack; st->stack_cap = new_cap; } static void table_stack_push(pl_table_state *st, pl_tabled_subgoal *sg, const ULO *dbg_dat_ptr) { if (!st || !sg) { return; } if (sg->evaluating) { return; } table_stack_ensure_cap(st, dbg_dat_ptr, st->stack_count + 1); st->stack[st->stack_count] = sg; sg->stack_index = st->stack_count; st->stack_count++; sg->leader = sg; sg->evaluating = true; sg->complete = false; sg->new_answer = false; } static void table_stack_pop_to(pl_table_state *st, ULO new_count) { if (!st) { return; } if (new_count > st->stack_count) { return; } for (ULO i = new_count; i < st->stack_count; i++) { pl_tabled_subgoal *sg = st->stack[i]; if (!sg) { continue; } sg->evaluating = false; sg->stack_index = (ULO)~(ULO)0; sg->leader = sg; st->stack[i] = NULL; } st->stack_count = new_count; } static void table_scc_merge(pl_table_state *st, pl_tabled_subgoal *target, const ULO *dbg_dat_ptr) { if (!st || !st->current || !target) { return; } pl_tabled_subgoal *cur = st->current; if (!cur->evaluating || !target->evaluating) { return; } pl_tabled_subgoal *lc = cur->leader ? cur->leader : cur; pl_tabled_subgoal *lt = target->leader ? target->leader : target; if (!lc || !lt || lc == lt) { return; } const ULO idx_c = lc->stack_index; const ULO idx_t = lt->stack_index; if (idx_c == (ULO)~(ULO)0 || idx_t == (ULO)~(ULO)0) { return; } pl_tabled_subgoal *new_leader = (idx_c < idx_t) ? lc : lt; const ULO start = (idx_c < idx_t) ? idx_c : idx_t; const ULO end = cur->stack_index; if (end == (ULO)~(ULO)0 || end >= st->stack_count) { return; } for (ULO i = start; i <= end && i < st->stack_count; i++) { pl_tabled_subgoal *sg = st->stack[i]; if (sg) { sg->leader = new_leader; } } (void)dbg_dat_ptr; } static pl_tabled_subgoal *table_intern_call(pl_program *prog, pl_term *goal, const pl_env *env_in, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !goal || !g_table_state) { return NULL; } pl_term *frozen = freeze_bound_vars_rt(goal, env_in, rt_ctrl, dbg_dat_ptr, 0); const uint64_t h = table_hash_term_variant(frozen, dbg_dat_ptr); pl_table_state *st = g_table_state; pl_tabled_subgoal *sg = table_state_lookup(st, frozen, h, dbg_dat_ptr); if (sg) { return sg; } pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &st->alloc; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_env dummy = {0}; pl_term *key = copy_term_tr(frozen, NULL, &dummy, &m, rt_ctrl, dbg_dat_ptr, 0); copy_var_map_free(&m); g_temp_alloc = saved_tmp; return table_state_insert(st, key, h, dbg_dat_ptr); } static bool table_subgoal_add_answer(pl_tabled_subgoal *sg, pl_term *call_goal, const pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!sg || !call_goal || !g_table_state) { return false; } pl_term *ans_tmp = freeze_bound_vars_rt(call_goal, env, rt_ctrl, dbg_dat_ptr, 0); if (!ans_tmp) { return false; } for (ULO i = 0; i < sg->answer_count; i++) { pl_term *a = sg->answers ? sg->answers[i] : NULL; if (a && term_variant_env(ans_tmp, a, NULL, dbg_dat_ptr)) { return false; } } pl_table_state *st = g_table_state; pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &st->alloc; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_env dummy = {0}; pl_term *ans = copy_term_tr(ans_tmp, NULL, &dummy, &m, rt_ctrl, dbg_dat_ptr, 0); copy_var_map_free(&m); g_temp_alloc = saved_tmp; if (!ans) { return false; } if (sg->answer_count == sg->answer_cap) { ULO new_cap = sg->answer_cap ? (sg->answer_cap * 2) : 16; pl_term **new_items = (pl_term **)realloc(sg->answers, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } sg->answers = new_items; sg->answer_cap = new_cap; } sg->answers[sg->answer_count++] = ans; sg->new_answer = true; return true; } typedef struct { pl_tabled_subgoal *sg; pl_term *call_goal; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_table_gen_ctx; static void table_gen_on_solution(const pl_env *env, void *ctx0) { pl_table_gen_ctx *ctx = (pl_table_gen_ctx *)ctx0; if (!ctx || !ctx->sg || !ctx->call_goal) { return; } (void)table_subgoal_add_answer(ctx->sg, ctx->call_goal, env, ctx->rt_ctrl, ctx->dbg_dat_ptr); } static pl_cut_signal table_eval_user_predicate_direct(pl_program *prog, const pl_query *q, pl_term *goal, const pl_env *env_in, const void *exc_barrier, ULO depth, pl_on_solution_fn on_solution, void *on_solution_ctx, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !goal || !on_solution) { return cut_none(); } if (flowlog_cancelled()) { return cut_none(); } if (!prog->clause_count || !prog->clauses) { for (ULO i = 1; i <= prog->fact_count; i++) { const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal, prog->facts[i], env1, rt_ctrl, dbg_dat_ptr)) { on_solution(env1, on_solution_ctx); } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } return cut_none(); } const CHR *goal_name = NULL; ULO goal_arity = 0; if (goal->tag == PL_TERM_ATOM) { goal_name = goal->v.atom_name; goal_arity = 0; } else if (goal->tag == PL_TERM_STRUCT) { goal_name = goal->v.str.functor; goal_arity = goal->v.str.arity; } else { return cut_none(); } const pl_clause **cands = NULL; ULO cand_count = 0; if (goal_name && prog->clause_count && prog->clauses) { cands = prog_snapshot_pred_cands(prog, goal_name, goal_arity, goal, env_in, &cand_count, rt_ctrl, dbg_dat_ptr); if (!cands && prog->clause_count) { cands = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(*cands) * prog->clause_count, dbg_dat_ptr); for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *hn = NULL; ULO ha = 0; if (h->tag == PL_TERM_ATOM) { hn = h->v.atom_name; ha = 0; } else if (h->tag == PL_TERM_STRUCT) { hn = h->v.str.functor; ha = h->v.str.arity; } else { continue; } if (hn && (ha == goal_arity) && !strcmp(hn, goal_name)) { cands[cand_count++] = cl; } } } } int pred_barrier = 0; for (ULO ci = 0; ci < cand_count; ci++) { const pl_clause *cl = cands[ci]; if (!cl || !cl->head) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); env1->intro_scope = scope; env_apply_clause_bindings_arena(cl, scope, env1, &arena, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal, head, env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } if (!cl->body_count) { on_solution(env1, on_solution_ctx); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } pl_term **body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO j = 1; j <= cl->body_count; j++) { body_goals[j - 1] = clone_term_with_scope_arena(cl->body[j], cl->scope, scope, &arena, dbg_dat_ptr, 0); } ULO local_sol = 0; const pl_clause *saved_clause = g_trace_clause; const pl_clause *saved_argv_clause = flowlog_argv_clause_push(cl); g_trace_clause = cl; pl_cut_signal r = solve_goals_cb(prog, q, body_goals, cl->body_count, env1, &pred_barrier, exc_barrier, depth + 1, false, NULL, &local_sol, on_solution, on_solution_ctx, rt_ctrl, dbg_dat_ptr); flowlog_argv_clause_pop(saved_argv_clause); g_trace_clause = saved_clause; if (r.except) { return r; } if (r.cut) { if (r.target == &pred_barrier) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return r; } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } if (prog && prog->flag_trace) { trace_emit_prolog_term('!', depth, "FAIL", goal, env_in, NULL); } return cut_none(); } static pl_cut_signal table_eval_subgoal_once(pl_program *prog, const pl_query *q, pl_tabled_subgoal *sg, const void *exc_barrier, ULO depth, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !sg || !sg->key || !g_table_state) { return cut_none(); } pl_table_state *st = g_table_state; pl_tabled_subgoal *saved_current = st->current; st->current = sg; pl_env empty = {0}; pl_table_gen_ctx ctx = {.sg = sg, .call_goal = sg->key, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr}; pl_cut_signal r = table_eval_user_predicate_direct(prog, q, sg->key, &empty, exc_barrier, depth + 1, table_gen_on_solution, &ctx, rt_ctrl, dbg_dat_ptr); st->current = saved_current; return r; } static pl_cut_signal table_complete_scc(pl_program *prog, const pl_query *q, pl_tabled_subgoal *leader, const void *exc_barrier, ULO depth, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !leader || !g_table_state) { return cut_none(); } pl_table_state *st = g_table_state; if (!leader->evaluating || leader->complete) { return cut_none(); } if (leader->leader != leader) { return cut_none(); } const ULO leader_idx = leader->stack_index; if (leader_idx == (ULO)~(ULO)0 || leader_idx >= st->stack_count) { return cut_none(); } pl_cut_signal r = table_eval_subgoal_once(prog, q, leader, exc_barrier, depth, rt_ctrl, dbg_dat_ptr); if (r.except || r.cut) { return r; } if (leader->leader != leader) { return cut_none(); } for (;;) { bool any_new = false; for (ULO i = leader_idx; i < st->stack_count; i++) { pl_tabled_subgoal *sg = st->stack[i]; if (!sg) { continue; } if (sg->new_answer) { any_new = true; break; } } if (!any_new) { break; } for (ULO i = leader_idx; i < st->stack_count; i++) { pl_tabled_subgoal *sg = st->stack[i]; if (sg) { sg->new_answer = false; } } for (ULO i = leader_idx; i < st->stack_count; i++) { pl_tabled_subgoal *sg = st->stack[i]; if (!sg) { continue; } r = table_eval_subgoal_once(prog, q, sg, exc_barrier, depth, rt_ctrl, dbg_dat_ptr); if (r.except || r.cut) { return r; } } } const ULO old_count = st->stack_count; for (ULO i = leader_idx; i < old_count; i++) { pl_tabled_subgoal *sg = st->stack[i]; if (!sg) { continue; } sg->complete = true; sg->new_answer = false; } table_stack_pop_to(st, leader_idx); return cut_none(); } static pl_cut_signal table_consume_answers(pl_program *prog, const pl_query *q, pl_term *goal, pl_tabled_subgoal *sg, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, pl_on_solution_fn on_solution, void *on_solution_ctx, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !sg || !goal || !goals || goal_count < 1) { return cut_none(); } for (ULO ai = 0; ai < sg->answer_count; ai++) { if (stop_at_first && *sol_count) { return cut_none(); } if (flowlog_cancelled()) { return cut_none(); } const bool release_temp = g_temp_alloc && ((on_solution == NULL) || g_on_solution_safe_temp_release); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_term *ans = sg->answers[ai]; pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!ans || !unify_terms(goal, ans, env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } pl_cut_signal r = solve_goals_cb(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, on_solution, on_solution_ctx, rt_ctrl, dbg_dat_ptr); if (r.except) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return r; } if (r.cut) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return r; } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } return cut_none(); } static pl_cut_signal table_call(pl_program *prog, const pl_query *q, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, pl_on_solution_fn on_solution, void *on_solution_ctx, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !goal || !g_table_state) { return cut_none(); } pl_tabled_subgoal *sg = table_intern_call(prog, goal, env_in, rt_ctrl, dbg_dat_ptr); if (!sg) { return cut_none(); } if (sg->evaluating && !sg->complete) { table_scc_merge(g_table_state, sg, dbg_dat_ptr); return table_consume_answers(prog, q, goal, sg, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, on_solution, on_solution_ctx, rt_ctrl, dbg_dat_ptr); } if (sg->complete) { return table_consume_answers(prog, q, goal, sg, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, on_solution, on_solution_ctx, rt_ctrl, dbg_dat_ptr); } // Flowlog extension: parallel transitive-closure fast-path for tabled right-linear Pred/2 recursion with a ground start. // // This preserves call-by-variant tabling semantics (unique answers) while exploiting worker-thread parallelism for // pure reachability problems (e.g. `path/2`). if (!sg->evaluating && !sg->complete && prog && goal && goal->tag == PL_TERM_STRUCT && goal->v.str.arity == 2) { pl_temp_alloc *saved_tmp = g_temp_alloc; pl_temp_alloc tmp = {0}; g_temp_alloc = &tmp; const bool ok = table_try_tc_fastpath(prog, goal, env_in, sg, rt_ctrl, dbg_dat_ptr); g_temp_alloc = saved_tmp; temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); if (ok) { sg->evaluating = false; sg->complete = true; return table_consume_answers(prog, q, goal, sg, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, on_solution, on_solution_ctx, rt_ctrl, dbg_dat_ptr); } } table_stack_push(g_table_state, sg, dbg_dat_ptr); pl_tabled_subgoal *saved_current = g_table_state->current; g_table_state->current = sg; pl_cut_signal r = table_complete_scc(prog, q, sg, exc_barrier, depth, rt_ctrl, dbg_dat_ptr); g_table_state->current = saved_current; if (r.except || r.cut) { return r; } return table_consume_answers(prog, q, goal, sg, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, on_solution, on_solution_ctx, rt_ctrl, dbg_dat_ptr); } /* --- SUBSECTION 20.3: WAM Tabling ---------------------------------------- */ // WAM tabling helpers. // wam_scope_var_count_for_term() sizes scopes; table_subgoal_add_answer_wam() and table_gen_on_solution_wam() register answers. struct pl_wam_cont; static void wam_apply_clause_bindings_arena(const pl_clause *cl, const pl_scope *to_scope, pl_term_arena *arena, pl_wam_cell *cells, ULO cell_count, pl_wam_trail *trail, const void *rt_ctrl, const ULO *dbg_dat_ptr); static pl_cut_signal solve_goals_wam_cb(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, const struct pl_wam_cont *cont); static pl_cut_signal solve_goals_wamvm_cb(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, const struct pl_wam_cont *cont); // // Table keys/answers are stored as persistent terms with their own scopes. // When consuming answers in the WAM engine, we must temporarily "wire" the // answer scope into the active `pl_wam_state` (allocate cells) so unification // can bind/explore existential variables introduced by tabling. static const pl_scope *term_find_first_scope_tr(pl_term *t, ULO depth); static void term_max_var_id_for_scope_tr(pl_term *t, const pl_scope *scope, ULO *io_max, ULO depth); static ULO wam_scope_var_count_for_term(pl_term *t, const pl_scope *scope, const ULO *dbg_dat_ptr) { if (!t || !scope) { return 0; } if (scope->var_count) { return scope->var_count; } ULO max_var_id = 0; term_max_var_id_for_scope_tr(t, scope, &max_var_id, 0); (void)dbg_dat_ptr; return max_var_id + 1; } static pl_tabled_subgoal *table_intern_call_wam(pl_program *prog, pl_term *goal, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !goal || !g_table_state) { return NULL; } pl_term *frozen = freeze_bound_vars_wam_rt(goal, rt_ctrl, dbg_dat_ptr, 0); const uint64_t h = table_hash_term_variant(frozen, dbg_dat_ptr); pl_table_state *st = g_table_state; pl_tabled_subgoal *sg = table_state_lookup(st, frozen, h, dbg_dat_ptr); if (sg) { return sg; } pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &st->alloc; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_env dummy = {0}; pl_term *key = copy_term_tr(frozen, NULL, &dummy, &m, rt_ctrl, dbg_dat_ptr, 0); scope->var_count = m.next_var_id; copy_var_map_free(&m); g_temp_alloc = saved_tmp; if (!key) { return NULL; } return table_state_insert(st, key, h, dbg_dat_ptr); } static bool table_subgoal_add_answer_wam(pl_tabled_subgoal *sg, pl_term *call_goal, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!sg || !call_goal || !g_table_state) { return false; } pl_term *ans_tmp = freeze_bound_vars_wam_rt(call_goal, rt_ctrl, dbg_dat_ptr, 0); if (!ans_tmp) { return false; } for (ULO i = 0; i < sg->answer_count; i++) { pl_term *a = sg->answers ? sg->answers[i] : NULL; if (a && term_variant_env(ans_tmp, a, NULL, dbg_dat_ptr)) { return false; } } pl_table_state *st = g_table_state; pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &st->alloc; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_env dummy = {0}; pl_term *ans = copy_term_tr(ans_tmp, NULL, &dummy, &m, rt_ctrl, dbg_dat_ptr, 0); scope->var_count = m.next_var_id; copy_var_map_free(&m); g_temp_alloc = saved_tmp; if (!ans) { return false; } if (sg->answer_count == sg->answer_cap) { ULO new_cap = sg->answer_cap ? (sg->answer_cap * 2) : 16; pl_term **new_items = (pl_term **)realloc(sg->answers, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } sg->answers = new_items; sg->answer_cap = new_cap; } sg->answers[sg->answer_count++] = ans; sg->new_answer = true; return true; } typedef struct { pl_tabled_subgoal *sg; pl_term *call_goal; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_table_gen_wam_ctx; static void table_gen_on_solution_wam(pl_wam_state *st, void *ctx0, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)st; (void)rt_ctrl; (void)dbg_dat_ptr; pl_table_gen_wam_ctx *ctx = (pl_table_gen_wam_ctx *)ctx0; if (!ctx || !ctx->sg || !ctx->call_goal) { return; } (void)table_subgoal_add_answer_wam(ctx->sg, ctx->call_goal, ctx->rt_ctrl, ctx->dbg_dat_ptr); } static pl_cut_signal table_eval_subgoal_once_wam(pl_program *prog, const pl_query *q, pl_tabled_subgoal *sg, pl_wam_state *st, const void *exc_barrier, ULO depth, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !q || !sg || !sg->key || !g_table_state || !st) { return cut_none(); } if (flowlog_cancelled()) { return cut_none(); } pl_table_state *tbl = g_table_state; pl_tabled_subgoal *saved_current = tbl->current; tbl->current = sg; const ULO trail_mark = st->trail.count; const ULO scope_mark = st->scope_count; // Wire the subgoal key scope (if any) so WAM unification can bind variables. const pl_scope *key_scope = term_find_first_scope_tr(sg->key, 0); if (key_scope) { const ULO var_count = wam_scope_var_count_for_term(sg->key, key_scope, dbg_dat_ptr); (void)wam_state_push_scope(st, (pl_scope *)key_scope, var_count, rt_ctrl, dbg_dat_ptr); } // Run the goal and capture each solution as a table answer. const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; pl_table_gen_wam_ctx ctx = {.sg = sg, .call_goal = sg->key, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr}; g_wam_on_solution = table_gen_on_solution_wam; g_wam_on_solution_ctx = &ctx; // Evaluate the predicate body directly (like the interpreter tabling path) so // the initial generator call does not recurse back into table_call_wam/.. as a // consumer. Recursive *body* calls still go through table_call_wam. const CHR *pred_name = NULL; ULO pred_arity = 0; if (sg->key->tag == PL_TERM_ATOM) { pred_name = sg->key->v.atom_name; pred_arity = 0; } else if (sg->key->tag == PL_TERM_STRUCT) { pred_name = sg->key->v.str.functor; pred_arity = sg->key->v.str.arity; } const pl_clause **cands = NULL; ULO cand_count = 0; if (pred_name) { cands = prog_snapshot_pred_cands(prog, pred_name, pred_arity, sg->key, NULL, &cand_count, rt_ctrl, dbg_dat_ptr); } if (!cands) { cand_count = 0; } int pred_barrier = 0; pl_cut_signal r = cut_none(); for (ULO ci = 0; ci < cand_count; ci++) { const pl_clause *cl = cands[ci]; if (!cl || !cl->head) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(st, scope, cl->var_count, rt_ctrl, dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st->trail, rt_ctrl, dbg_dat_ptr); if (!unify_terms_wam(sg->key, head, &st->trail, dbg_dat_ptr)) { wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } ULO dummy_sol = 0; if (!cl->body_count) { r = solve_goals_wam_cb(prog, q, NULL, 0, st, &pred_barrier, exc_barrier, depth + 1, false, NULL, &dummy_sol, rt_ctrl, dbg_dat_ptr, NULL); } else { pl_term **body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO j = 1; j <= cl->body_count; j++) { body_goals[j - 1] = clone_term_with_scope_arena(cl->body[j], cl->scope, scope, &arena, dbg_dat_ptr, 0); } r = solve_goals_wam_cb(prog, q, body_goals, cl->body_count, st, &pred_barrier, exc_barrier, depth + 1, false, NULL, &dummy_sol, rt_ctrl, dbg_dat_ptr, NULL); } wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (r.except) { break; } if (r.cut) { if (r.target == &pred_barrier) { r = cut_none(); } break; } } g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; // Restore WAM state (bindings + scopes introduced by the generator run). wam_trail_unwind(&st->trail, trail_mark); st->scope_count = scope_mark; tbl->current = saved_current; return r; } static pl_cut_signal table_complete_scc_wam(pl_program *prog, const pl_query *q, pl_tabled_subgoal *leader, pl_wam_state *st, const void *exc_barrier, ULO depth, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !q || !leader || !g_table_state || !st) { return cut_none(); } pl_table_state *tbl = g_table_state; if (!leader->evaluating || leader->complete) { return cut_none(); } if (leader->leader != leader) { return cut_none(); } const ULO leader_idx = leader->stack_index; if (leader_idx == (ULO)~(ULO)0 || leader_idx >= tbl->stack_count) { return cut_none(); } pl_cut_signal r = table_eval_subgoal_once_wam(prog, q, leader, st, exc_barrier, depth, rt_ctrl, dbg_dat_ptr); if (r.except || r.cut) { return r; } if (leader->leader != leader) { return cut_none(); } for (;;) { bool any_new = false; for (ULO i = leader_idx; i < tbl->stack_count; i++) { pl_tabled_subgoal *sg = tbl->stack[i]; if (!sg) { continue; } if (sg->new_answer) { any_new = true; break; } } if (!any_new) { break; } for (ULO i = leader_idx; i < tbl->stack_count; i++) { pl_tabled_subgoal *sg = tbl->stack[i]; if (sg) { sg->new_answer = false; } } for (ULO i = leader_idx; i < tbl->stack_count; i++) { pl_tabled_subgoal *sg = tbl->stack[i]; if (!sg) { continue; } r = table_eval_subgoal_once_wam(prog, q, sg, st, exc_barrier, depth, rt_ctrl, dbg_dat_ptr); if (r.except || r.cut) { return r; } } } const ULO old_count = tbl->stack_count; for (ULO i = leader_idx; i < old_count; i++) { pl_tabled_subgoal *sg = tbl->stack[i]; if (!sg) { continue; } sg->complete = true; sg->new_answer = false; } table_stack_pop_to(tbl, leader_idx); return cut_none(); } static pl_cut_signal table_consume_answers_wam(pl_program *prog, const pl_query *q, pl_term *goal, pl_tabled_subgoal *sg, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, const struct pl_wam_cont *cont) { if (!prog || !q || !sg || !goal || !goals || goal_count < 1 || !st || !sol_count) { return cut_none(); } for (ULO ai = 0; ai < sg->answer_count; ai++) { if (stop_at_first && *sol_count) { return cut_none(); } if (flowlog_cancelled()) { return cut_none(); } const ULO trail_mark = st->trail.count; const ULO scope_mark = st->scope_count; pl_term *ans = sg->answers[ai]; if (!ans) { continue; } const pl_scope *ans_scope = term_find_first_scope_tr(ans, 0); if (ans_scope) { const ULO var_count = wam_scope_var_count_for_term(ans, ans_scope, dbg_dat_ptr); (void)wam_state_push_scope(st, (pl_scope *)ans_scope, var_count, rt_ctrl, dbg_dat_ptr); } pl_cut_signal r = cut_none(); if (unify_terms_wam(goal, ans, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, trail_mark); st->scope_count = scope_mark; if (r.except) { return r; } if (r.cut) { return r; } } return cut_none(); } static pl_cut_signal table_call_wam(pl_program *prog, const pl_query *q, pl_term *goal, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, const struct pl_wam_cont *cont) { if (!prog || !q || !goal || !g_table_state || !st) { return cut_none(); } pl_tabled_subgoal *sg = table_intern_call_wam(prog, goal, rt_ctrl, dbg_dat_ptr); if (!sg) { return cut_none(); } if (sg->evaluating && !sg->complete) { table_scc_merge(g_table_state, sg, dbg_dat_ptr); return table_consume_answers_wam(prog, q, goal, sg, goals, goal_count, st, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (sg->complete) { return table_consume_answers_wam(prog, q, goal, sg, goals, goal_count, st, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } table_stack_push(g_table_state, sg, dbg_dat_ptr); pl_tabled_subgoal *saved_current = g_table_state->current; g_table_state->current = sg; pl_cut_signal r = table_complete_scc_wam(prog, q, sg, st, exc_barrier, depth, rt_ctrl, dbg_dat_ptr); g_table_state->current = saved_current; if (r.except || r.cut) { return r; } return table_consume_answers_wam(prog, q, goal, sg, goals, goal_count, st, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } /* ============================================================================ * SECTION 21: Parallel OR/AND Jobs * OR/AND-par job structs, work queues, and worker execution paths. * ============================================================================ */ /* --- SUBSECTION 21.1: OR-par Job Types ----------------------------------- */ // OR-par job kinds and variants. // pl_or_job_kind enumerates fact/clause/range jobs plus WAM/WAMVM-specific job types. typedef enum { PL_OR_JOB_FACT = 1, PL_OR_JOB_CLAUSE = 2, PL_OR_JOB_FACT_RANGE = 3, PL_OR_JOB_CLAUSE_RANGE = 4, PL_OR_JOB_WORKER = 5, PL_OR_JOB_JOIN_CLAUSE = 6, PL_OR_JOB_JOIN_CLAUSE_RANGE = 7, PL_OR_JOB_SELECT1_RANGE = 8, // WAM-lite OR-par jobs. PL_OR_JOB_WAM_CLAUSE = 9, PL_OR_JOB_WAM_CLAUSE_RANGE = 10, PL_OR_JOB_WAM_SELECT1_RANGE = 11, // WAMVM OR-par jobs (bytecode VM path). PL_OR_JOB_WAMVM_SELECT1_RANGE = 12, } pl_or_job_kind; /* --- SUBSECTION 21.2: OR-par Job Structures ------------------------------ */ // OR-par job/work structures and chunk scheduling. // pl_or_job/pl_or_work carry per-job state; orpar_worker_count_for_alts()/orpar_try_claim_chunk() compute worker counts and claim chunks. typedef struct pl_or_work pl_or_work; typedef struct pl_or_job { pl_or_job_kind kind; pl_program *prog; const pl_query *q; pl_term *goal; // deref'd goal term (shared, immutable) const pl_env *env_in; const pl_wam_state *wam_in; // WAM baseline state (immutable) for WAM job kinds const struct pl_wam_cont *wam_cont; // WAM continuation chain (heap-copied) for WAM job kinds const pl_wamvm_prog_code *wamvm_code; // WAMVM compiled code (optional; immutable) pl_term *drop; pl_term *const *rest_goals; // original goals[1..] ULO rest_count; const void *cut_barrier; // caller's predicate barrier address const void *exc_barrier; ULO depth; bool stop_at_first; bool capture_solution_output; // capture output (also enabled for REPL span tracking) bool capture_solution_spans; // set by caller when REPL solution streaming is active pl_on_solution_fn on_solution; void *on_solution_ctx; pl_on_solution_wam_fn wam_on_solution; void *wam_on_solution_ctx; bool on_solution_safe_temp_release; // Optimization: when true, OR-par chunk jobs created by `pl_or_prepare` may // allocate query-temporary state from the process-local heap (reallocpool) // instead of shared memory. This is safe for top-level query OR-par because // intermediate pointers do not cross instruction boundaries; exceptions are // stringified within the job. bool local_alloc_ok; // When true, uncaught exceptions are stringified within the job and term/env // pointers are cleared to avoid cross-worker dereference (used for top-level // OR-par across multiple CPUPROC processes). bool stringify_exceptions; // Ordered-commit chunk index (0-based). Used to avoid cancelling earlier alternatives when running OR-par. ULO chunk_index; union { const pl_term *fact; const pl_clause *cl; struct { const pl_term **facts; // points to prog->facts (1-based, index 0 unused) ULO start; // 0-based alternative index (fact at facts[start+1]) ULO end; // exclusive } fact_range; struct { const pl_clause **cands; // candidate clauses array (0-based) ULO start; // inclusive ULO end; // exclusive } clause_range; struct { pl_term *list0; // deref'd list (shared, immutable during job) const CHR *cons_functor; // usually "." (shared string pointer) ULO start; // inclusive 0-based element index ULO end; // exclusive } select1_range; struct { pl_or_work *work; } worker; } u; atomic_int *work_done; atomic_int *work_cancel; int budget_return; // number of global budget tokens to return when this worker finishes atomic_int done; // 0 = running, 1 = complete // Results CHR *out_str; // NUL-terminated output (shared memory when run in parallel) SLO out_descr; // async heap descriptor for out_str (0 when allocated via reallocpool) pl_solution_span *out_spans; // solution spans within out_str (when streaming) SLO out_spans_descr; ULO out_spans_count; ULO sol_count; pl_cut_signal sig; pl_temp_snapshot *except_snapshot; // only set when sig.except==true } pl_or_job; typedef struct pl_or_work { ULO count; pl_or_job *jobs; ULO chunk_count; pl_or_job *chunks; bool unordered; // when true, commit/solution order is not preserved (faster search) atomic_ulong next_chunk; atomic_ulong commit_chunk; // next chunk index to commit/cancel (0-based) atomic_ulong max_chunk; // inclusive max chunk index allowed (ordered prune) atomic_int done; // completed job count atomic_int cancel; // cooperative cancellation flag atomic_int *par_budget; // shared per-query CPUPROC budget (may be NULL) atomic_int budget_returned; // number of tokens returned early by workers int budget_total; // total tokens reserved for this OR-par work (0 => none) pl_temp_snapshot *alloc_snapshot; // when non-NULL, this work is persistent across UDF calls // Debugging (optional; enabled via FLOWLOG_DEBUG_ORPAR). uint64_t dbg_t0_ns; atomic_ulong dbg_first_cut_chunk; // ULONG_MAX when none observed } pl_or_work; static ULO orpar_worker_count_for_alts(ULO alt_count, ULO max_threads) { if (alt_count < 2) { return 1; } ULO worker_count = max_threads; if (worker_count < 2) { worker_count = 2; } if (worker_count > alt_count) { worker_count = alt_count; } ULO max_by_alts = 1 + (alt_count / (ULO)FLOWLOG_ORPAR_MIN_ALTS_PER_WORKER); if (max_by_alts < 2) { max_by_alts = 2; } if (max_by_alts > alt_count) { max_by_alts = alt_count; } if (worker_count > max_by_alts) { worker_count = max_by_alts; } if (worker_count < 2) { worker_count = 2; } if (worker_count > alt_count) { worker_count = alt_count; } return worker_count; } static unsigned long orpar_ordered_lookahead(ULO worker_count, ULO chunk_count) { if (chunk_count < 2) { return 0; } unsigned long look = (unsigned long)(worker_count * (ULO)FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MULT); if (look < (unsigned long)FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MIN) { look = (unsigned long)FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MIN; } if (look > (unsigned long)FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MAX) { look = (unsigned long)FLOWLOG_ORPAR_ORDERED_LOOKAHEAD_MAX; } // Convert "lookahead count" into a maximum chunk index offset (inclusive). if (look >= (unsigned long)chunk_count) { look = (unsigned long)chunk_count - 1; } return look; } static bool orpar_try_claim_chunk(pl_or_work *work, unsigned long *out_idx) { if (!work || !out_idx || !work->chunks || !work->chunk_count) { return false; } for (;;) { const unsigned long idx = atomic_load_explicit(&work->next_chunk, memory_order_relaxed); if ((ULO)idx >= work->chunk_count) { return false; // all chunks claimed } const unsigned long max_chunk = atomic_load_explicit(&work->max_chunk, memory_order_relaxed); unsigned long limit = max_chunk; if (!work->unordered) { const unsigned long commit = atomic_load_explicit(&work->commit_chunk, memory_order_relaxed); const unsigned long look = orpar_ordered_lookahead(work->count, work->chunk_count); limit = commit + look; if ((ULO)limit >= work->chunk_count) { limit = (unsigned long)work->chunk_count - 1; } if (max_chunk < limit) { limit = max_chunk; } } // Too far ahead: let the committer advance first (ordered), or respect pruning (unordered). if (idx > limit) { return false; } unsigned long expected = idx; if (atomic_compare_exchange_weak_explicit(&work->next_chunk, &expected, idx + 1, memory_order_acq_rel, memory_order_relaxed)) { *out_idx = idx; return true; } } } static pl_cut_signal join_solve_facts(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, const pl_env *env_in, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth); /* --- SUBSECTION 21.3: AND-par Job Structures ----------------------------- */ // AND-par job structures and thread contexts. // pl_and_job/pl_and_job_wam capture per-goal execution; temp_snapshot_free_all() releases snapshots after merging. typedef struct { pl_program *prog; const pl_query *q; pl_term *goal; // deref'd goal term (shared, immutable) const pl_env *env_in; const void *cut_barrier; const void *exc_barrier; ULO depth; atomic_int *work_done; atomic_int *work_cancel; atomic_int done; // 0 = running, 1 = complete // Results bool ok; pl_cut_signal sig; const pl_env *env_out; // first (and only) solution environment when ok==true pl_temp_snapshot *tmp_snapshot; // set when env_out differs or sig.except==true } pl_and_job; typedef struct { ULO count; pl_and_job *jobs; atomic_int done; // completed job count atomic_int cancel; // cooperative cancellation flag atomic_int *par_budget; // shared per-query CPUPROC budget (may be NULL) } pl_and_work; static void pl_and_job_run(pl_and_job *job, const void *rt_ctrl, const ULO *dbg_dat_ptr); // WAM-lite AND-par jobs (used by solve_goals_wam_cb when flowlog_parallel_and is enabled). typedef struct { pl_program *prog; const pl_query *q; pl_term *goal; // deref'd goal term (shared, immutable) // Free variables reachable from Goal at dispatch time (used to merge // bindings back into the main WAM state when the job succeeds). pl_var_list vars; const pl_wam_state *wam_in; // baseline WAM state (immutable) ULO base_scope_count; // scope_count in baseline state const void *cut_barrier; const void *exc_barrier; ULO depth; atomic_int *work_done; atomic_int *work_cancel; atomic_int done; // 0 = running, 1 = complete // Results bool ok; pl_cut_signal sig; pl_wam_state *wam_out; // snapshot of the WAM state at first solution (when ok==true) pl_temp_snapshot *tmp_snapshot; // allocations for wam_out and/or exception terms (adopted into g_par_state by the caller) } pl_and_job_wam; typedef struct { ULO count; pl_and_job_wam *jobs; atomic_int done; // completed job count atomic_int cancel; // cooperative cancellation flag atomic_int *par_budget; // shared per-query CPUPROC budget (may be NULL) } pl_and_work_wam; static void pl_and_job_wam_run(pl_and_job_wam *job, const void *rt_ctrl, const ULO *dbg_dat_ptr); typedef struct { pl_or_job *job; pl_parallel_state *par; atomic_int *par_budget; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_or_thread_ctx; static void *pl_or_thread_main(void *arg); typedef struct { pl_and_job *job; pl_parallel_state *par; atomic_int *par_budget; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_and_job_thread_ctx; static void *pl_and_job_thread_main(void *arg); typedef struct { pl_and_job_wam *job; pl_parallel_state *par; atomic_int *par_budget; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_and_job_wam_thread_ctx; static void *pl_and_job_wam_thread_main(void *arg); static void temp_snapshot_free_all(pl_temp_snapshot *snap, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!snap) { return; } for (size_t j = 0; j < snap->descr_count; j++) { shm_free_descr(rt_ctrl, dbg_dat_ptr, snap->descrs[j]); } for (size_t j = 0; j < snap->pool_count; j++) { freepool(snap->pool_ptrs[j]); } for (size_t j = 0; j < snap->malloc_count; j++) { free(snap->malloc_ptrs[j]); } if (snap->descrs_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, snap->descrs_descr); } else { free(snap->descrs); } if (snap->pool_ptrs_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, snap->pool_ptrs_descr); } else { free(snap->pool_ptrs); } if (snap->malloc_ptrs_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, snap->malloc_ptrs_descr); } else { free(snap->malloc_ptrs); } const SLO self_descr = snap->self_descr; if (self_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, self_descr); } else { free(snap); } } /* --- SUBSECTION 21.4: OR-par Job Execution ------------------------------- */ // OR-par execution helpers. // pl_or_job_run()/pl_or_merge_output()/pl_or_job_dispose() manage worker results, output merging, and cleanup. static void pl_or_job_dispose(pl_or_job *job, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!job) { return; } if (job->out_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, job->out_descr); job->out_descr = 0; job->out_str = NULL; } else if (job->out_str) { freepool(job->out_str); job->out_str = NULL; } if (job->out_spans_descr) { shm_free_descr(rt_ctrl, dbg_dat_ptr, job->out_spans_descr); job->out_spans_descr = 0; job->out_spans = NULL; } else if (job->out_spans) { freepool(job->out_spans); job->out_spans = NULL; } job->out_spans_count = 0; if (job->except_snapshot) { temp_snapshot_free_all(job->except_snapshot, rt_ctrl, dbg_dat_ptr); job->except_snapshot = NULL; } } static void pl_or_merge_output(pl_sbuf *sol_out, pl_sbuf *io_out, ULO *global_sol_count, const pl_or_job *job) { if (!global_sol_count || !job) { return; } if (g_solution_stream) { if (job->out_str && job->out_str[0]) { const size_t out_len = strlen(job->out_str); size_t prev = 0; if (job->out_spans && job->out_spans_count) { for (ULO i = 0; i < job->out_spans_count; i++) { const pl_solution_span span = job->out_spans[i]; if (span.start < prev || span.end < span.start || span.end > out_len) { continue; } if (span.start > prev) { (void)solution_stream_emit_output(g_solution_stream, job->out_str + prev, span.start - prev); } if (span.end > span.start) { (void)solution_stream_emit_solution(g_solution_stream, job->out_str + span.start, span.end - span.start); } prev = span.end; } } else if (job->sol_count > 0) { // Spans should always be present when streaming; fall back to treating // the buffer as plain output to avoid misclassifying user writes. } if (out_len > prev) { (void)solution_stream_emit_output(g_solution_stream, job->out_str + prev, out_len - prev); } } } else if (job->out_str && job->out_str[0]) { if (sol_out) { if (job->sol_count && *global_sol_count) { sbuf_append_char(sol_out, '\n'); } sbuf_append_cstr(sol_out, job->out_str); } else if (io_out) { sbuf_append_cstr(io_out, job->out_str); } } *global_sol_count += job->sol_count; } static void pl_or_job_run(pl_or_job *job, const void *rt_ctrl, const ULO *dbg_dat_ptr); static void pl_pool_task_run_or(void *arg, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_or_job_run((pl_or_job *)arg, rt_ctrl, dbg_dat_ptr); } static void pl_pool_task_run_and(void *arg, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_and_job_run((pl_and_job *)arg, rt_ctrl, dbg_dat_ptr); } static void pl_pool_task_run_and_wam(void *arg, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_and_job_wam_run((pl_and_job_wam *)arg, rt_ctrl, dbg_dat_ptr); } static ULO flowlog_start_or_work(const pl_or_work *work, ULO start_idx, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!work || !work->jobs || !work->count) { return 0; } if (!start_idx || start_idx > work->count) { return 0; } if (!am_I_in_the_CPUPROC_module()) { return 0; } // Start internal OR-par worker threads (deep parallelism inside a single query). const ULO spawn_n = work->count - start_idx + 1; if (!spawn_n) { return 0; } // Cap worker thread count for stability; override with FLOWLOG_ORPAR_MAX_WORKERS. ULO cap = spawn_n; const char *cap_env = getenv("FLOWLOG_ORPAR_MAX_WORKERS"); if (cap_env && *cap_env) { char *end = NULL; unsigned long long v = strtoull(cap_env, &end, 10); if (end && *end == '\0' && v > 0) { cap = (ULO)v; } } else { const ULO ncpu = get_n_cpuproc(); if (ncpu > 0 && cap > ncpu) { cap = ncpu; } } if (cap > spawn_n) { cap = spawn_n; } if (g_par_state && par_pool_ensure(g_par_state, rt_ctrl, dbg_dat_ptr)) { ULO scheduled = 0; for (ULO i = 0; i < cap; i++) { const ULO job_idx = start_idx + i; pl_or_job *job = &work->jobs[job_idx - 1]; pl_pool_task *t = (pl_pool_task *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); *t = (pl_pool_task){ .fn = pl_pool_task_run_or, .arg = job, .prog = job ? job->prog : NULL, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, .next = NULL, }; par_pool_enqueue(g_par_state, t); scheduled++; } return scheduled; } pl_or_thread_ctx *ctx = (pl_or_thread_ctx *)pool_alloc(rt_ctrl, sizeof(*ctx) * cap, dbg_dat_ptr); memset(ctx, 0, sizeof(*ctx) * cap); // OR-par workers execute deep recursive solver code. The default pthread stack // size on many systems is too small for realistic Prolog workloads and can // lead to hard-to-diagnose crashes (stack overflows reported as SIGSEGV). // // Use a larger detached-thread stack by default; allow tuning via env var. pthread_attr_t attr; bool have_attr = (pthread_attr_init(&attr) == 0); if (have_attr) { (void)pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); size_t stack_sz = flowlog_default_orpar_stack_size_bytes(cap); const char *env = getenv("FLOWLOG_ORPAR_STACK_SIZE"); if (env && *env) { char *end = NULL; unsigned long long v = strtoull(env, &end, 10); if (end && *end == '\0' && v >= (unsigned long long)PTHREAD_STACK_MIN) { stack_sz = (size_t)v; } } if (stack_sz < (size_t)PTHREAD_STACK_MIN) { stack_sz = (size_t)PTHREAD_STACK_MIN; } // Ignore failures and fall back to the implementation default. (void)pthread_attr_setstacksize(&attr, stack_sz); } ULO created = 0; for (ULO i = 0; i < cap; i++) { const ULO job_idx = start_idx + i; ctx[i] = (pl_or_thread_ctx){ .job = &work->jobs[job_idx - 1], .par = g_par_state, .par_budget = work->par_budget, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, }; pthread_t th; const int rc = pthread_create(&th, have_attr ? &attr : NULL, pl_or_thread_main, &ctx[i]); if (rc != 0) { break; } created++; } if (have_attr) { (void)pthread_attr_destroy(&attr); } return created; } static bool flowlog_start_and_work(const pl_and_work *work, ULO start_idx, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!work || !work->jobs || !work->count) { return false; } if (!start_idx) { return false; } if (start_idx > work->count) { return true; // nothing to start } if (!am_I_in_the_CPUPROC_module()) { return false; } const ULO spawn_n = work->count - start_idx + 1; if (!spawn_n) { return true; } if (g_par_state && par_pool_ensure(g_par_state, rt_ctrl, dbg_dat_ptr)) { for (ULO i = 0; i < spawn_n; i++) { const ULO job_idx = start_idx + i; pl_and_job *job = &work->jobs[job_idx - 1]; pl_pool_task *t = (pl_pool_task *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); *t = (pl_pool_task){ .fn = pl_pool_task_run_and, .arg = job, .prog = job ? job->prog : NULL, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, .next = NULL, }; par_pool_enqueue(g_par_state, t); } return true; } // Best-effort: if we cannot start all workers, run remaining jobs // synchronously so awaiters don't deadlock. pl_and_job_thread_ctx *ctx = (pl_and_job_thread_ctx *)pool_alloc(rt_ctrl, sizeof(*ctx) * spawn_n, dbg_dat_ptr); memset(ctx, 0, sizeof(*ctx) * spawn_n); pthread_attr_t attr; const bool have_attr = (pthread_attr_init(&attr) == 0); if (have_attr) { (void)pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); } ULO created = 0; for (ULO i = 0; i < spawn_n; i++) { const ULO job_idx = start_idx + i; ctx[i] = (pl_and_job_thread_ctx){ .job = &work->jobs[job_idx - 1], .par = g_par_state, .par_budget = work->par_budget, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, }; pthread_t th; const int rc = pthread_create(&th, have_attr ? &attr : NULL, pl_and_job_thread_main, &ctx[i]); if (rc != 0) { break; } created++; } if (have_attr) { (void)pthread_attr_destroy(&attr); } if (!created) { return false; } for (ULO i = created; i < spawn_n; i++) { const ULO job_idx = start_idx + i; pl_and_job_run(&work->jobs[job_idx - 1], rt_ctrl, dbg_dat_ptr); } return true; } static bool flowlog_start_and_work_wam(const pl_and_work_wam *work, ULO start_idx, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!work || !work->jobs || !work->count) { return false; } if (!start_idx) { return false; } if (start_idx > work->count) { return true; // nothing to start } if (!am_I_in_the_CPUPROC_module()) { return false; } const ULO spawn_n = work->count - start_idx + 1; if (!spawn_n) { return true; } if (g_par_state && par_pool_ensure(g_par_state, rt_ctrl, dbg_dat_ptr)) { for (ULO i = 0; i < spawn_n; i++) { const ULO job_idx = start_idx + i; pl_and_job_wam *job = &work->jobs[job_idx - 1]; pl_pool_task *t = (pl_pool_task *)pool_alloc(rt_ctrl, sizeof(*t), dbg_dat_ptr); *t = (pl_pool_task){ .fn = pl_pool_task_run_and_wam, .arg = job, .prog = job ? job->prog : NULL, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, .next = NULL, }; par_pool_enqueue(g_par_state, t); } return true; } // Best-effort: if we cannot start all workers, run remaining jobs // synchronously so callers don't deadlock on job completion. pl_and_job_wam_thread_ctx *ctx = (pl_and_job_wam_thread_ctx *)pool_alloc(rt_ctrl, sizeof(*ctx) * spawn_n, dbg_dat_ptr); memset(ctx, 0, sizeof(*ctx) * spawn_n); pthread_attr_t attr; const bool have_attr = (pthread_attr_init(&attr) == 0); if (have_attr) { (void)pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); } ULO created = 0; for (ULO i = 0; i < spawn_n; i++) { const ULO job_idx = start_idx + i; ctx[i] = (pl_and_job_wam_thread_ctx){ .job = &work->jobs[job_idx - 1], .par = g_par_state, .par_budget = work->par_budget, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, }; pthread_t th; const int rc = pthread_create(&th, have_attr ? &attr : NULL, pl_and_job_wam_thread_main, &ctx[i]); if (rc != 0) { break; } created++; } if (have_attr) { (void)pthread_attr_destroy(&attr); } if (!created) { return false; } for (ULO i = created; i < spawn_n; i++) { const ULO job_idx = start_idx + i; pl_and_job_wam_run(&work->jobs[job_idx - 1], rt_ctrl, dbg_dat_ptr); } return true; } static void flowlog_wait_done(const atomic_int *done, int expected) { if (!done || expected <= 0) { return; } while (atomic_load(done) < expected) { usleep(1000); } } static void pl_or_work_budget_reconcile(pl_or_work *work) { if (!work || !work->par_budget || work->budget_total <= 0) { return; } const int returned = atomic_load(&work->budget_returned); int remaining = work->budget_total - returned; if (remaining > 0) { par_global_budget_give(work->par_budget, remaining); } work->budget_total = 0; } static void pl_or_maybe_ordered_cancel(pl_or_job *job) { if (!job || !job->work_cancel) { return; } if (!job->sig.cut && !job->sig.except) { return; } const pl_or_work *work = (const pl_or_work *)((const char *)job->work_cancel - offsetof(pl_or_work, cancel)); if (!work) { return; } if (!work->unordered) { const unsigned long commit = atomic_load_explicit(&work->commit_chunk, memory_order_relaxed); if ((ULO)commit != job->chunk_index) { return; } } atomic_store(job->work_cancel, 1); } static void pl_or_job_run(pl_or_job *job, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!job || !job->prog) { return; } const bool saved_drain_ok = g_stdio_capture_drain_ok; g_stdio_capture_drain_ok = false; const atomic_int *saved_cancel = g_cancel_flag; g_cancel_flag = job->work_cancel; if (flowlog_cancelled()) { job->sol_count = 0; job->sig = cut_none(); if (job->kind == PL_OR_JOB_WORKER && job->budget_return > 0) { pl_or_work *work = job->u.worker.work; if (work && work->par_budget && work->budget_total > 0) { atomic_fetch_add(&work->budget_returned, job->budget_return); par_global_budget_give(work->par_budget, job->budget_return); } job->budget_return = 0; } if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_stdio_capture_drain_ok = saved_drain_ok; return; } // Ordered OR-par pruning: if an earlier chunk has already produced a cut, we // will never need to evaluate later chunks. Skip them cooperatively. if (job->kind != PL_OR_JOB_WORKER && job->work_cancel) { pl_or_work *work = (pl_or_work *)((char *)job->work_cancel - offsetof(pl_or_work, cancel)); if (work) { const unsigned long max_chunk = atomic_load_explicit(&work->max_chunk, memory_order_relaxed); if ((unsigned long)job->chunk_index > max_chunk) { job->sol_count = 0; job->sig = cut_none(); job->out_str = NULL; job->out_descr = 0; job->out_spans = NULL; job->out_spans_descr = 0; job->out_spans_count = 0; job->except_snapshot = NULL; if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_stdio_capture_drain_ok = saved_drain_ok; return; } } } if (job->kind == PL_OR_JOB_WORKER) { pl_or_work *work = job->u.worker.work; if (work && work->chunks && work->chunk_count) { for (;;) { if (flowlog_cancelled()) { break; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&work->chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } // Either all work is claimed, or we're bounded by ordered commit. const unsigned long next = atomic_load_explicit(&work->next_chunk, memory_order_relaxed); const unsigned long max_chunk = atomic_load_explicit(&work->max_chunk, memory_order_relaxed); if ((ULO)next >= work->chunk_count || next > max_chunk) { break; } usleep(1000); } } job->sol_count = 0; job->sig = cut_none(); job->out_str = NULL; job->out_descr = 0; job->out_spans = NULL; job->out_spans_descr = 0; job->out_spans_count = 0; job->except_snapshot = NULL; if (job->budget_return > 0) { if (work && work->par_budget && work->budget_total > 0) { atomic_fetch_add(&work->budget_returned, job->budget_return); par_global_budget_give(work->par_budget, job->budget_return); } job->budget_return = 0; } if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_stdio_capture_drain_ok = saved_drain_ok; return; } const bool saved_safe_temp_release = g_on_solution_safe_temp_release; g_on_solution_safe_temp_release = job->on_solution_safe_temp_release; const pl_on_solution_wam_fn saved_wam_on_solution = g_wam_on_solution; void *saved_wam_on_solution_ctx = g_wam_on_solution_ctx; g_wam_on_solution = job->wam_on_solution; g_wam_on_solution_ctx = job->wam_on_solution_ctx; const int saved_orpar_level = g_orpar_level; g_orpar_level = saved_orpar_level + 1; const bool saved_local_alloc = g_pool_local_alloc; if (job->local_alloc_ok) { g_pool_local_alloc = true; } pl_temp_alloc *saved_tmp = g_temp_alloc; pl_temp_alloc tmp = {0}; g_temp_alloc = &tmp; pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_sbuf *saved_capture = g_stdio_capture; g_stdio_capture = &sb; pl_sbuf *job_out = job->capture_solution_output ? &sb : NULL; pl_solution_capture cap = {0}; pl_solution_capture *saved_sol_cap = g_solution_capture; const bool capture_spans = (job->capture_solution_spans && job_out != NULL); if (capture_spans) { cap.out = job_out; cap.retain_output = true; g_solution_capture = ∩ } ULO sol = 0; pl_cut_signal sig = cut_none(); if (job->kind == PL_OR_JOB_FACT) { pl_env *env1 = env_clone(job->env_in, rt_ctrl, dbg_dat_ptr); if (job->goal && job->u.fact && unify_terms(job->goal, (pl_term *)job->u.fact, env1, rt_ctrl, dbg_dat_ptr)) { const ULO new_goal_count = 1 + job->rest_count; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = job->drop; for (ULO i = 0; i < job->rest_count; i++) { new_goals[i + 1] = job->rest_goals[i]; } sig = solve_goals_cb(job->prog, job->q, new_goals, new_goal_count, env1, job->cut_barrier, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, job->on_solution, job->on_solution_ctx, rt_ctrl, dbg_dat_ptr); } } else if (job->kind == PL_OR_JOB_FACT_RANGE) { const pl_term **facts = job->u.fact_range.facts; const ULO start = job->u.fact_range.start; const ULO end = job->u.fact_range.end; if (facts && job->goal && (start < end)) { for (ULO fi = start; fi < end; fi++) { if (flowlog_cancelled()) { break; } const pl_term *fact = facts[fi + 1]; if (!fact) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_env *env1 = env_clone(job->env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(job->goal, (pl_term *)fact, env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } const ULO new_goal_count = 1 + job->rest_count; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = job->drop; for (ULO i = 0; i < job->rest_count; i++) { new_goals[i + 1] = job->rest_goals[i]; } pl_cut_signal r = solve_goals_cb(job->prog, job->q, new_goals, new_goal_count, env1, job->cut_barrier, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, job->on_solution, job->on_solution_ctx, rt_ctrl, dbg_dat_ptr); if (r.except || r.cut) { sig = r; break; } if (job->stop_at_first && sol) { break; } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } } } else if (job->kind == PL_OR_JOB_CLAUSE) { const pl_clause *cl = job->u.cl; if (cl && cl->head && job->goal) { pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_env *env1 = env_clone(job->env_in, rt_ctrl, dbg_dat_ptr); env1->intro_scope = scope; env_apply_clause_bindings_arena(cl, scope, env1, &arena, rt_ctrl, dbg_dat_ptr); if (unify_terms(job->goal, head, env1, rt_ctrl, dbg_dat_ptr)) { const ULO new_goal_count = cl->body_count + 1 + job->rest_count; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } ULO pos = 0; for (ULO j = 1; j <= cl->body_count; j++) { new_goals[pos++] = clone_term_with_scope_arena(cl->body[j], cl->scope, scope, &arena, dbg_dat_ptr, 0); } new_goals[pos++] = job->drop; for (ULO j = 0; j < job->rest_count; j++) { new_goals[pos++] = job->rest_goals[j]; } sig = solve_goals_cb(job->prog, job->q, new_goals, new_goal_count, env1, job->cut_barrier, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, job->on_solution, job->on_solution_ctx, rt_ctrl, dbg_dat_ptr); } } } else if (job->kind == PL_OR_JOB_CLAUSE_RANGE) { const pl_clause **cands = job->u.clause_range.cands; const ULO start = job->u.clause_range.start; const ULO end = job->u.clause_range.end; if (cands && job->goal && (start < end)) { for (ULO ci = start; ci < end; ci++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = cands[ci]; if (!cl || !cl->head) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_env *env1 = env_clone(job->env_in, rt_ctrl, dbg_dat_ptr); env1->intro_scope = scope; env_apply_clause_bindings_arena(cl, scope, env1, &arena, rt_ctrl, dbg_dat_ptr); if (!unify_terms(job->goal, head, env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } const ULO new_goal_count = cl->body_count + 1 + job->rest_count; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } ULO pos = 0; for (ULO j = 1; j <= cl->body_count; j++) { new_goals[pos++] = clone_term_with_scope_arena(cl->body[j], cl->scope, scope, &arena, dbg_dat_ptr, 0); } new_goals[pos++] = job->drop; for (ULO j = 0; j < job->rest_count; j++) { new_goals[pos++] = job->rest_goals[j]; } pl_cut_signal r = solve_goals_cb(job->prog, job->q, new_goals, new_goal_count, env1, job->cut_barrier, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, job->on_solution, job->on_solution_ctx, rt_ctrl, dbg_dat_ptr); if (r.except || r.cut) { sig = r; break; } if (job->stop_at_first && sol) { break; } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } } } else if (job->kind == PL_OR_JOB_JOIN_CLAUSE) { const pl_clause *cl = job->u.cl; if (cl && cl->head && !cl->body_count && job->goal) { pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_env *env1 = env_clone(job->env_in, rt_ctrl, dbg_dat_ptr); env1->intro_scope = scope; env_apply_clause_bindings_arena(cl, scope, env1, &arena, rt_ctrl, dbg_dat_ptr); if (unify_terms(job->goal, head, env1, rt_ctrl, dbg_dat_ptr)) { sig = join_solve_facts(job->prog, job->q, job->rest_goals, job->rest_count, env1, job_out, &sol, rt_ctrl, dbg_dat_ptr, job->depth + 1); } } } else if (job->kind == PL_OR_JOB_JOIN_CLAUSE_RANGE) { const pl_clause **cands = job->u.clause_range.cands; const ULO start = job->u.clause_range.start; const ULO end = job->u.clause_range.end; if (cands && job->goal && (start < end)) { for (ULO ci = start; ci < end; ci++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = cands[ci]; if (!cl || !cl->head || cl->body_count) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_env *env1 = env_clone(job->env_in, rt_ctrl, dbg_dat_ptr); env1->intro_scope = scope; env_apply_clause_bindings_arena(cl, scope, env1, &arena, rt_ctrl, dbg_dat_ptr); if (!unify_terms(job->goal, head, env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } pl_cut_signal r = join_solve_facts(job->prog, job->q, job->rest_goals, job->rest_count, env1, job_out, &sol, rt_ctrl, dbg_dat_ptr, job->depth + 1); if (r.except || r.cut) { sig = r; break; } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } } } else if (job->kind == PL_OR_JOB_SELECT1_RANGE) { pl_term *list0 = job->u.select1_range.list0; const CHR *cons_functor = job->u.select1_range.cons_functor; const ULO start = job->u.select1_range.start; const ULO end = job->u.select1_range.end; if (list0 && job->goal && (start < end)) { enum { FLOWLOG_SELECT1_PREFIX_CAP = 256 }; pl_term **prefix = (pl_term **)pool_alloc(rt_ctrl, (ULO)(sizeof(*prefix) * (size_t)FLOWLOG_SELECT1_PREFIX_CAP), dbg_dat_ptr); size_t prefix_count = 0; pl_term *cur = list0; ULO idx = 0; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); bool cycle = false; while (1) { if (flowlog_cancelled()) { break; } if (idx >= end) { break; } cur = deref_term(cur, job->env_in); if (!cur) { break; } if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { break; } pl_term *head = cur->v.str.args[0]; pl_term *tail = cur->v.str.args[1]; if (idx >= start) { const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } // Build Rest = Prefix ++ Tail. pl_term *rest = tail; if (prefix_count) { const size_t align = sizeof(void *); const size_t term_bytes = prefix_count * sizeof(pl_term); const size_t term_bytes_aligned = (term_bytes + align - 1) & ~(align - 1); const size_t args_bytes = prefix_count * 2 * sizeof(pl_term *); const size_t total_bytes = term_bytes_aligned + args_bytes; void *mem = pool_alloc(rt_ctrl, (ULO)total_bytes, dbg_dat_ptr); pl_term *terms = (pl_term *)mem; pl_term **args = (pl_term **)((char *)mem + term_bytes_aligned); for (size_t i = prefix_count; i > 0; i--) { const size_t ci = prefix_count - i; pl_term *cons = &terms[ci]; cons->tag = PL_TERM_STRUCT; cons->builtin = 0; cons->reserved16 = 0; cons->v.str.arity = 2; cons->v.str.functor = (CHR *)(cons_functor ? cons_functor : "."); cons->v.str.args = &args[ci * 2]; cons->v.str.args[0] = prefix[i - 1]; cons->v.str.args[1] = rest; rest = cons; } } pl_env *env1 = env_clone(job->env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(job->goal->v.str.args[0], head, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(job->goal->v.str.args[2], rest, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals_cb(job->prog, job->q, job->rest_goals, job->rest_count, env1, job->cut_barrier, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, job->on_solution, job->on_solution_ctx, rt_ctrl, dbg_dat_ptr); if (r.except || r.cut) { sig = r; break; } if (job->stop_at_first && sol) { break; } } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } if (prefix_count < (size_t)FLOWLOG_SELECT1_PREFIX_CAP) { prefix[prefix_count++] = head; } else { sig = throw_representation_error(job->exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); break; } cur = tail; idx++; if (list_cycle_guard_step_tr(&cg, job->env_in)) { cycle = true; break; } } if (cycle) { sig = throw_representation_error(job->exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } } } else if (job->kind == PL_OR_JOB_WAM_SELECT1_RANGE) { const pl_wam_state *wam_in = job->wam_in; pl_term *list0 = job->u.select1_range.list0; const CHR *cons_functor = job->u.select1_range.cons_functor; const ULO start = job->u.select1_range.start; const ULO end = job->u.select1_range.end; if (wam_in && list0 && job->goal && (start < end) && job->goal->tag == PL_TERM_STRUCT && job->goal->v.str.args) { pl_wam_state st = {0}; wam_state_clone_into(&st, wam_in, rt_ctrl, dbg_dat_ptr); pl_wam_state *saved_wam = g_wam_state; g_wam_state = &st; const size_t prefix_cap = 256; pl_term **prefix = (pl_term **)pool_alloc(rt_ctrl, (ULO)(sizeof(*prefix) * prefix_cap), dbg_dat_ptr); size_t prefix_count = 0; pl_term *cur = list0; ULO idx = 0; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); bool cycle = false; while (1) { if (flowlog_cancelled()) { break; } if (idx >= end) { break; } cur = deref_term_wam(cur); if (!cur) { break; } if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { break; } pl_term *head = cur->v.str.args[0]; pl_term *tail = cur->v.str.args[1]; if (idx >= start) { // Build Rest = Prefix ++ Tail. pl_term *rest = tail; if (prefix_count) { const size_t align = sizeof(void *); const size_t term_bytes = prefix_count * sizeof(pl_term); const size_t term_bytes_aligned = (term_bytes + align - 1) & ~(align - 1); const size_t args_bytes = prefix_count * 2 * sizeof(pl_term *); const size_t total_bytes = term_bytes_aligned + args_bytes; void *mem = pool_alloc(rt_ctrl, (ULO)total_bytes, dbg_dat_ptr); pl_term *terms = (pl_term *)mem; pl_term **args = (pl_term **)((char *)mem + term_bytes_aligned); for (size_t i = prefix_count; i > 0; i--) { const size_t ci = prefix_count - i; pl_term *cons = &terms[ci]; cons->tag = PL_TERM_STRUCT; cons->builtin = 0; cons->reserved16 = 0; cons->v.str.arity = 2; cons->v.str.functor = (CHR *)(cons_functor ? cons_functor : "."); cons->v.str.args = &args[ci * 2]; cons->v.str.args[0] = prefix[i - 1]; cons->v.str.args[1] = rest; rest = cons; } } const ULO mark = st.trail.count; if (unify_terms_wam(job->goal->v.str.args[0], head, &st.trail, dbg_dat_ptr) && unify_terms_wam(job->goal->v.str.args[2], rest, &st.trail, dbg_dat_ptr)) { pl_cut_signal r = solve_goals_wam_cb(job->prog, job->q, job->rest_goals, job->rest_count, &st, job->cut_barrier, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, rt_ctrl, dbg_dat_ptr, job->wam_cont); if (r.except || r.cut) { sig = r; } } wam_trail_unwind(&st.trail, mark); if (sig.except || sig.cut) { break; } if (job->stop_at_first && sol) { break; } } if (prefix_count < prefix_cap) { prefix[prefix_count++] = head; } else { sig = throw_representation_error(job->exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); break; } cur = tail; idx++; if (list_cycle_guard_step_wam_always(&cg)) { cycle = true; break; } } if (cycle) { sig = throw_representation_error(job->exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } g_wam_state = saved_wam; wam_trail_free(&st.trail); free(st.scopes); st.scopes = NULL; st.scope_count = 0; st.scope_cap = 0; } } else if (job->kind == PL_OR_JOB_WAMVM_SELECT1_RANGE) { const pl_wam_state *wam_in = job->wam_in; pl_term *list0 = job->u.select1_range.list0; const ULO start = job->u.select1_range.start; const ULO end = job->u.select1_range.end; if (wam_in && list0 && job->goal && (start < end) && job->goal->tag == PL_TERM_STRUCT && job->goal->v.str.args) { pl_wam_state st = {0}; wam_state_clone_into(&st, wam_in, rt_ctrl, dbg_dat_ptr); pl_wam_state *saved_wam = g_wam_state; g_wam_state = &st; const pl_wamvm_prog_code *saved_code = g_wamvm_code; g_wamvm_code = job->wamvm_code; if (g_wamvm_code && (g_wamvm_code->prog != job->prog)) { g_wamvm_code = NULL; } if (!g_wamvm_code && job->prog) { g_wamvm_code = wamvm_program_code_build(job->prog, rt_ctrl, dbg_dat_ptr); } pl_wamvm_barrier base_bar = {.prev = NULL, .cp_base = 0}; // Run a single VM invocation with an internal generator goal so we don't // re-enter the WAMVM engine once per list element. pl_term *sel = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$select1_range", 5); sel->v.str.args[0] = job->goal->v.str.args[0]; sel->v.str.args[1] = job->goal->v.str.args[1]; sel->v.str.args[2] = job->goal->v.str.args[2]; sel->v.str.args[3] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)start); sel->v.str.args[4] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)end); const ULO new_goal_count = 1 + job->rest_count; pl_term **new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(*new_goals) * new_goal_count, dbg_dat_ptr); new_goals[0] = sel; for (ULO i = 0; i < job->rest_count; i++) { new_goals[i + 1] = job->rest_goals[i]; } pl_cut_signal r = solve_goals_wamvm_cb(job->prog, job->q, (pl_term *const *)new_goals, new_goal_count, &st, &base_bar, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, rt_ctrl, dbg_dat_ptr, job->wam_cont); if (r.except || r.cut) { sig = r; } g_wamvm_code = saved_code; g_wam_state = saved_wam; wam_trail_free(&st.trail); free(st.scopes); st.scopes = NULL; st.scope_count = 0; st.scope_cap = 0; } } else if (job->kind == PL_OR_JOB_WAM_CLAUSE || job->kind == PL_OR_JOB_WAM_CLAUSE_RANGE) { const pl_wam_state *wam_in = job->wam_in; const pl_clause **cands = NULL; ULO start = 0; ULO end = 0; const pl_clause *single = NULL; if (job->kind == PL_OR_JOB_WAM_CLAUSE) { single = job->u.cl; } else { cands = job->u.clause_range.cands; start = job->u.clause_range.start; end = job->u.clause_range.end; } if (wam_in && job->goal && job->drop && ((single != NULL) || (cands && (start < end)))) { pl_wam_state st = {0}; wam_state_clone_into(&st, wam_in, rt_ctrl, dbg_dat_ptr); pl_wam_state *saved_wam = g_wam_state; g_wam_state = &st; const bool use_wamvm = (g_engine_active == PL_ENGINE_WAMVM); const ULO ci_start = (single != NULL) ? 0 : start; const ULO ci_end = (single != NULL) ? 1 : end; for (ULO ci = ci_start; ci < ci_end; ci++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = single ? single : cands[ci]; if (!cl || !cl->head) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st.trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(&st, scope, cl->var_count, rt_ctrl, dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *vars = NULL; if (use_wamvm && cl->var_count) { vars = (pl_term *)pool_alloc(rt_ctrl, sizeof(*vars) * cl->var_count, dbg_dat_ptr); wamvm_vars_init(vars, cl->var_count, scope); } if (use_wamvm) { wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st.trail, rt_ctrl, dbg_dat_ptr); if (!wamvm_unify_against_clause_term(job->goal, cl->head, cl->scope, vars, cl->var_count, &st.trail, &arena, dbg_dat_ptr, 0)) { wam_trail_unwind(&st.trail, mark); wam_state_pop_scope(&st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } } else { pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st.trail, rt_ctrl, dbg_dat_ptr); if (!unify_terms_wam(job->goal, head, &st.trail, dbg_dat_ptr)) { wam_trail_unwind(&st.trail, mark); wam_state_pop_scope(&st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } } const ULO new_goal_count = cl->body_count + 1 + job->rest_count; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } ULO pos = 0; for (ULO j = 1; j <= cl->body_count; j++) { if (use_wamvm) { new_goals[pos++] = wamvm_instantiate_term_arena(cl->body[j], cl->scope, vars, cl->var_count, &arena, dbg_dat_ptr, 0); } else { new_goals[pos++] = clone_term_with_scope_arena(cl->body[j], cl->scope, scope, &arena, dbg_dat_ptr, 0); } } new_goals[pos++] = job->drop; for (ULO j = 0; j < job->rest_count; j++) { new_goals[pos++] = job->rest_goals[j]; } pl_cut_signal r = solve_goals_wam_cb(job->prog, job->q, new_goals, new_goal_count, &st, job->cut_barrier, job->exc_barrier, job->depth + 1, job->stop_at_first, job_out, &sol, rt_ctrl, dbg_dat_ptr, job->wam_cont); wam_trail_unwind(&st.trail, mark); wam_state_pop_scope(&st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (r.except || r.cut) { sig = r; break; } if (job->stop_at_first && sol) { break; } } g_wam_state = saved_wam; wam_trail_free(&st.trail); free(st.scopes); st.scopes = NULL; st.scope_count = 0; st.scope_cap = 0; } } job->sol_count = sol; job->sig = sig; if (sig.cut && job->work_cancel) { pl_or_work *work = (pl_or_work *)((char *)job->work_cancel - offsetof(pl_or_work, cancel)); unsigned long cur = atomic_load_explicit(&work->max_chunk, memory_order_relaxed); const unsigned long want = (unsigned long)job->chunk_index; while (want < cur) { if (atomic_compare_exchange_weak_explicit(&work->max_chunk, &cur, want, memory_order_acq_rel, memory_order_relaxed)) { break; } } } if (sig.cut && (flowlog_debug_orpar_level() > 0)) { const CHR *pred = NULL; ULO arity = 0; if (job->goal && job->goal->tag == PL_TERM_ATOM) { pred = job->goal->v.atom_name; arity = 0; } else if (job->goal && job->goal->tag == PL_TERM_STRUCT) { pred = job->goal->v.str.functor; arity = job->goal->v.str.arity; } pl_or_work *work = NULL; if (job->work_cancel) { work = (pl_or_work *)((char *)job->work_cancel - offsetof(pl_or_work, cancel)); } uint64_t dt_ns = 0; if (work && work->dbg_t0_ns) { const uint64_t now = flowlog_monotonic_ns(); if (now >= work->dbg_t0_ns) { dt_ns = now - work->dbg_t0_ns; } } if (work) { unsigned long expect = (unsigned long)ULONG_MAX; (void)atomic_compare_exchange_strong_explicit(&work->dbg_first_cut_chunk, &expect, (unsigned long)job->chunk_index, memory_order_acq_rel, memory_order_acquire); } const double ms = dt_ns ? ((double)dt_ns / 1000000.0) : 0.0; flowlog_debug_orpar_printf("flowlog: ORPAR cut %s/%lu chunk=%lu dt_ms=%.3f target=%p kind=%d sol=%lu\n", pred ? pred : "?", (unsigned long)arity, (unsigned long)job->chunk_index, ms, sig.target, (int)job->kind, (unsigned long)sol); } if (sig.except && job->stringify_exceptions) { // Top-level OR-par jobs can stringify uncaught exceptions locally, so we // don't need to preserve exception terms/environments in shared memory. // Match pl_solve_query/pl_or_collect behavior: return only the exception term text. sb.len = 0; if (sb.buf) { sb.buf[0] = '\0'; } pl_term *t0 = deref_term(sig.except_term, sig.except_env); const bool is_error = t0 && (t0->tag == PL_TERM_STRUCT) && (t0->v.str.arity == 2) && t0->v.str.functor && !strcmp(t0->v.str.functor, "error"); if (is_error) { term_to_sbuf(sig.except_term, sig.except_env, &sb, dbg_dat_ptr); } else { pl_term *wrap = make_struct_rt(rt_ctrl, dbg_dat_ptr, "throw", 1); wrap->v.str.args[0] = sig.except_term; term_to_sbuf(wrap, sig.except_env, &sb, dbg_dat_ptr); } // Prevent cross-process consumers from dereferencing job-local pointers. job->sig.except_term = NULL; job->sig.except_env = NULL; } pl_or_maybe_ordered_cancel(job); job->out_str = NULL; job->out_descr = 0; job->out_spans = NULL; job->out_spans_descr = 0; job->out_spans_count = 0; if (sb.buf && sb.len) { const size_t out_len = sb.len; SLO out_descr = 0; CHR *out_buf = NULL; if (g_orpar_thread_worker) { // Allocate process-local output for pthread OR-par workers; the committer // merges and frees it within the same address space. out_buf = (CHR *)reallocpool(NULL, (ULO)(out_len + 1)); out_descr = 0; } else { out_buf = (CHR *)shm_alloc(rt_ctrl, (SLO)(out_len + 1), dbg_dat_ptr, &out_descr); } if (out_buf) { memcpy(out_buf, sb.buf, out_len + 1); job->out_str = out_buf; job->out_descr = out_descr; } } if (capture_spans && cap.count) { const size_t bytes = cap.count * sizeof(*cap.spans); SLO span_descr = 0; pl_solution_span *span_buf = NULL; if (g_orpar_thread_worker) { span_buf = (pl_solution_span *)reallocpool(NULL, (ULO)bytes); span_descr = 0; } else { span_buf = (pl_solution_span *)shm_alloc(rt_ctrl, (SLO)bytes, dbg_dat_ptr, &span_descr); } if (span_buf) { memcpy(span_buf, cap.spans, bytes); job->out_spans = span_buf; job->out_spans_descr = span_descr; job->out_spans_count = cap.count; } } if (cap.spans) { freepool(cap.spans); cap.spans = NULL; cap.count = 0; cap.cap = 0; } g_solution_capture = saved_sol_cap; sbuf_free(&sb); g_stdio_capture = saved_capture; g_temp_alloc = saved_tmp; if (sig.except && !job->stringify_exceptions) { job->except_snapshot = temp_snapshot_from_temp_alloc(&tmp, rt_ctrl, dbg_dat_ptr); temp_alloc_drop_lists(&tmp); } else { temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); job->except_snapshot = NULL; } if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_wam_on_solution = saved_wam_on_solution; g_wam_on_solution_ctx = saved_wam_on_solution_ctx; g_pool_local_alloc = saved_local_alloc; g_orpar_level = saved_orpar_level; g_on_solution_safe_temp_release = saved_safe_temp_release; g_stdio_capture_drain_ok = saved_drain_ok; } static void pl_and_job_dispose(pl_and_job *job, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!job) { return; } if (job->tmp_snapshot) { temp_snapshot_free_all(job->tmp_snapshot, rt_ctrl, dbg_dat_ptr); job->tmp_snapshot = NULL; } } static void pl_and_job_wam_dispose(pl_and_job_wam *job, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!job) { return; } var_list_free(&job->vars); if (job->wam_out && job->wam_out->scopes) { free(job->wam_out->scopes); job->wam_out->scopes = NULL; job->wam_out->scope_count = 0; job->wam_out->scope_cap = 0; job->wam_out->q_scope_id = 0; job->wam_out->q_cells = NULL; } if (job->tmp_snapshot) { temp_snapshot_free_all(job->tmp_snapshot, rt_ctrl, dbg_dat_ptr); job->tmp_snapshot = NULL; } } static void pl_and_job_run(pl_and_job *job, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!job || !job->prog || !job->goal) { return; } const bool saved_drain_ok = g_stdio_capture_drain_ok; g_stdio_capture_drain_ok = false; const atomic_int *saved_cancel = g_cancel_flag; g_cancel_flag = job->work_cancel; if (flowlog_cancelled()) { job->ok = false; job->sig = cut_none(); job->env_out = job->env_in; job->tmp_snapshot = NULL; if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_stdio_capture_drain_ok = saved_drain_ok; return; } pl_temp_alloc *saved_tmp = g_temp_alloc; pl_temp_alloc tmp = {0}; g_temp_alloc = &tmp; ULO local_sol = 0; pl_once_ctx once = {0}; pl_term *goal_list[1] = {job->goal}; pl_cut_signal r = solve_goals_cb(job->prog, job->q, goal_list, 1, job->env_in, job->cut_barrier, job->exc_barrier, job->depth, true, NULL, &local_sol, once_on_solution, &once, rt_ctrl, dbg_dat_ptr); job->sig = r; job->ok = (!r.cut && !r.except && (local_sol > 0)); job->env_out = once.env ? once.env : job->env_in; job->tmp_snapshot = NULL; g_temp_alloc = saved_tmp; if (r.except || (job->env_out && (job->env_out != job->env_in))) { job->tmp_snapshot = temp_snapshot_from_temp_alloc(&tmp, rt_ctrl, dbg_dat_ptr); temp_alloc_drop_lists(&tmp); } else { temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); } if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_stdio_capture_drain_ok = saved_drain_ok; } typedef struct { bool got; pl_wam_state *out; } pl_and_once_wam_ctx; static void and_once_wam_on_solution(pl_wam_state *st, void *ctx0, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)rt_ctrl; pl_and_once_wam_ctx *ctx = (pl_and_once_wam_ctx *)ctx0; if (!ctx || ctx->got) { return; } ctx->got = true; ctx->out = (pl_wam_state *)pool_alloc(rt_ctrl, sizeof(*ctx->out), dbg_dat_ptr); wam_state_clone_into(ctx->out, st, rt_ctrl, dbg_dat_ptr); } static void pl_and_job_wam_run(pl_and_job_wam *job, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!job || !job->prog || !job->goal || !job->wam_in) { return; } const bool saved_drain_ok = g_stdio_capture_drain_ok; g_stdio_capture_drain_ok = false; const atomic_int *saved_cancel = g_cancel_flag; g_cancel_flag = job->work_cancel; if (flowlog_cancelled()) { job->ok = false; job->sig = cut_none(); job->wam_out = NULL; job->tmp_snapshot = NULL; if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_stdio_capture_drain_ok = saved_drain_ok; return; } pl_temp_alloc *saved_tmp = g_temp_alloc; pl_temp_alloc tmp = {0}; g_temp_alloc = &tmp; pl_wam_state st = {0}; pl_wam_state *saved_wam = g_wam_state; g_wam_state = &st; wam_state_clone_into(&st, job->wam_in, rt_ctrl, dbg_dat_ptr); const pl_on_solution_wam_fn saved_wam_on_solution = g_wam_on_solution; void *saved_wam_on_solution_ctx = g_wam_on_solution_ctx; pl_and_once_wam_ctx once = {0}; g_wam_on_solution = and_once_wam_on_solution; g_wam_on_solution_ctx = &once; ULO local_sol = 0; pl_term *goal_list[1] = {job->goal}; pl_cut_signal r = solve_goals_wam_cb(job->prog, job->q, goal_list, 1, &st, job->cut_barrier, job->exc_barrier, job->depth, true, NULL, &local_sol, rt_ctrl, dbg_dat_ptr, NULL); g_wam_on_solution = saved_wam_on_solution; g_wam_on_solution_ctx = saved_wam_on_solution_ctx; job->sig = r; job->ok = (!r.cut && !r.except && (local_sol > 0)); job->wam_out = once.out; job->tmp_snapshot = NULL; g_wam_state = saved_wam; wam_trail_free(&st.trail); free(st.scopes); st.scopes = NULL; st.scope_count = 0; st.scope_cap = 0; g_temp_alloc = saved_tmp; if (r.except || job->wam_out) { job->tmp_snapshot = temp_snapshot_from_temp_alloc(&tmp, rt_ctrl, dbg_dat_ptr); if (job->tmp_snapshot) { temp_alloc_drop_lists(&tmp); } else { // No tracked allocations: best-effort cleanup. temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); } } else { temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); } if (job->work_done) { (void)atomic_fetch_add(job->work_done, 1); } (void)atomic_store(&job->done, 1); g_cancel_flag = saved_cancel; g_stdio_capture_drain_ok = saved_drain_ok; } static void *pl_or_thread_main(void *arg) { pl_or_thread_ctx *ctx = (pl_or_thread_ctx *)arg; if (!ctx || !ctx->job || !ctx->par) { return NULL; } setup_thread_safe_functionality_for_local_thread(); flowlog_cstack_init_once(); #if defined(SIGSEGV) flowlog_install_sigsegv_trace_handler(atomic_load_explicit(&g_sigsegv_trace_enabled, memory_order_relaxed)); #endif const pl_program *saved_prog = g_current_prog; g_current_prog = ctx->job->prog; pl_parallel_state *saved_par = g_par_state; g_par_state = ctx->par; atomic_int *saved_budget = g_par_budget; g_par_budget = ctx->par_budget; const bool saved_orpar_thread = g_orpar_thread_worker; g_orpar_thread_worker = true; g_unify_occurs_check = ctx->job->prog ? ctx->job->prog->flag_occurs_check : false; g_halt_requested = false; g_halt_code = 0; pl_or_job_run(ctx->job, ctx->rt_ctrl, ctx->dbg_dat_ptr); g_par_state = saved_par; g_par_budget = saved_budget; g_orpar_thread_worker = saved_orpar_thread; g_current_prog = saved_prog; cleanup_thread_safe_functionality_for_local_thread(); return NULL; } static void *pl_and_job_thread_main(void *arg) { pl_and_job_thread_ctx *ctx = (pl_and_job_thread_ctx *)arg; if (!ctx || !ctx->job || !ctx->par) { return NULL; } setup_thread_safe_functionality_for_local_thread(); flowlog_cstack_init_once(); #if defined(SIGSEGV) flowlog_install_sigsegv_trace_handler(atomic_load_explicit(&g_sigsegv_trace_enabled, memory_order_relaxed)); #endif const pl_program *saved_prog = g_current_prog; g_current_prog = ctx->job->prog; pl_parallel_state *saved_par = g_par_state; g_par_state = ctx->par; atomic_int *saved_budget = g_par_budget; g_par_budget = ctx->par_budget; g_unify_occurs_check = ctx->job->prog ? ctx->job->prog->flag_occurs_check : false; g_halt_requested = false; g_halt_code = 0; pl_and_job_run(ctx->job, ctx->rt_ctrl, ctx->dbg_dat_ptr); g_par_state = saved_par; g_par_budget = saved_budget; g_current_prog = saved_prog; cleanup_thread_safe_functionality_for_local_thread(); return NULL; } static void *pl_and_job_wam_thread_main(void *arg) { pl_and_job_wam_thread_ctx *ctx = (pl_and_job_wam_thread_ctx *)arg; if (!ctx || !ctx->job || !ctx->par) { return NULL; } setup_thread_safe_functionality_for_local_thread(); flowlog_cstack_init_once(); #if defined(SIGSEGV) flowlog_install_sigsegv_trace_handler(atomic_load_explicit(&g_sigsegv_trace_enabled, memory_order_relaxed)); #endif const pl_program *saved_prog = g_current_prog; g_current_prog = ctx->job->prog; pl_parallel_state *saved_par = g_par_state; g_par_state = ctx->par; atomic_int *saved_budget = g_par_budget; g_par_budget = ctx->par_budget; const bool saved_orpar_thread = g_orpar_thread_worker; g_orpar_thread_worker = true; const bool saved_local_alloc = g_pool_local_alloc; g_pool_local_alloc = flowlog_pool_local_alloc_enabled(); const pl_engine_mode saved_engine = g_engine_active; g_engine_active = ctx->par->engine_active; g_unify_occurs_check = ctx->job->prog ? ctx->job->prog->flag_occurs_check : false; g_halt_requested = false; g_halt_code = 0; pl_and_job_wam_run(ctx->job, ctx->rt_ctrl, ctx->dbg_dat_ptr); g_engine_active = saved_engine; g_pool_local_alloc = saved_local_alloc; g_orpar_thread_worker = saved_orpar_thread; g_par_state = saved_par; g_par_budget = saved_budget; g_current_prog = saved_prog; cleanup_thread_safe_functionality_for_local_thread(); return NULL; } static bool par_and_builtin_is_safe_static(const CHR *fn, ULO ar) { if (!fn) { return false; } if (ar == 0) { return !strcmp(fn, "true") || !strcmp(fn, "fail") || !strcmp(fn, "false"); } if (ar == 1) { if (!strcmp(fn, "var") || !strcmp(fn, "nonvar") || !strcmp(fn, "atom") || !strcmp(fn, "integer") || !strcmp(fn, "float") || !strcmp(fn, "number") || !strcmp(fn, "atomic") || !strcmp(fn, "compound") || !strcmp(fn, "callable") || !strcmp(fn, "ground") || !strcmp(fn, "acyclic_term") || !strcmp(fn, "$flowlog_sleep_ms")) { return true; } } else if (ar == 2) { if (!strcmp(fn, "=") || !strcmp(fn, "is") || !strcmp(fn, "==") || !strcmp(fn, "\\==") || !strcmp(fn, "\\=") || !strcmp(fn, "=@=") || !strcmp(fn, "\\=@=") || !strcmp(fn, "=:=") || !strcmp(fn, "=\\=") || !strcmp(fn, "<") || !strcmp(fn, "=<") || !strcmp(fn, ">") || !strcmp(fn, ">=") || !strcmp(fn, "@<") || !strcmp(fn, "@=<") || !strcmp(fn, "@>") || !strcmp(fn, "@>=") || !strcmp(fn, "=..") || !strcmp(fn, "unify_with_occurs_check") || !strcmp(fn, "subsumes_term") || !strcmp(fn, "copy_term") || !strcmp(fn, "term_variables") || !strcmp(fn, "atom_length") || !strcmp(fn, "atom_chars") || !strcmp(fn, "atom_codes") || !strcmp(fn, "number_chars") || !strcmp(fn, "number_codes") || !strcmp(fn, "char_code") || !strcmp(fn, "sort") || !strcmp(fn, "keysort") || !strcmp(fn, "succ")) { return true; } } else if (ar == 3) { if (!strcmp(fn, "functor") || !strcmp(fn, "arg") || !strcmp(fn, "compare") || !strcmp(fn, "numbervars")) { return true; } } return false; } static bool par_and_goal_is_safe_static(pl_program *prog, const pl_term *goal) { if (!goal) { return false; } if (!prog || !prog->pred_index) { return false; } const CHR *fn = NULL; ULO ar = 0; if (goal->tag == PL_TERM_ATOM) { fn = goal->v.atom_name; ar = 0; } else if (goal->tag == PL_TERM_STRUCT) { fn = goal->v.str.functor; ar = goal->v.str.arity; } else { return false; } if (!fn) { return false; } // Accept a small, conservative built-in safe set (including internal helpers) // even if it is not part of builtin_pred_defined(). if (par_and_builtin_is_safe_static(fn, ar)) { return true; } if (builtin_pred_defined(fn, ar)) { return false; } if (prog_tabled_pred_contains(prog, fn, ar)) { return false; } pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, fn, ar); return e && (e->and_safe != 0); } static void prog_par_and_analyze_locked(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !prog->pred_index) { return; } pl_pred_index *idx = prog->pred_index; for (ULO i = 0; i < idx->pred_count; i++) { idx->preds[i].and_safe = 0; } bool changed = true; ULO iter = 0; while (changed && iter++ < (idx->pred_count + 1)) { changed = false; for (ULO i = 0; i < idx->pred_count; i++) { pl_pred_index_entry *e = &idx->preds[i]; if (!e->name) { continue; } if (e->and_safe) { continue; } if (e->clause_count != 1 || !e->clauses || !e->clauses[0]) { continue; } const pl_clause *cl = e->clauses[0]; bool ok = true; if (cl && cl->body_count && cl->body) { for (ULO bi = 1; bi <= cl->body_count; bi++) { const pl_term *g = cl->body[bi]; if (!g) { ok = false; break; } if (!par_and_goal_is_safe_static(prog, g)) { ok = false; break; } } } if (ok) { e->and_safe = 1; changed = true; } } } (void)rt_ctrl; (void)dbg_dat_ptr; } static void prog_par_and_safety_ensure(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog) { return; } const unsigned long cur = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long idx_built = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); const unsigned long safe_built = atomic_load_explicit(&prog->and_safe_epoch, memory_order_acquire); if ((idx_built == cur) && (safe_built == cur)) { return; } prog_db_wlock(prog); const unsigned long cur2 = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long idx_built2 = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); if (idx_built2 != cur2) { pl_temp_alloc *saved_tmp = NULL; if (g_temp_alloc) { saved_tmp = temp_alloc_suspend(); } prog_index_build_locked(prog, rt_ctrl, dbg_dat_ptr); if (saved_tmp) { temp_alloc_resume(saved_tmp); } atomic_store_explicit(&prog->index_epoch, cur2, memory_order_release); } const unsigned long safe_built2 = atomic_load_explicit(&prog->and_safe_epoch, memory_order_acquire); const unsigned long idx_built3 = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); if (safe_built2 != idx_built3) { prog_par_and_analyze_locked(prog, rt_ctrl, dbg_dat_ptr); atomic_store_explicit(&prog->and_safe_epoch, idx_built3, memory_order_release); } prog_db_wunlock(prog); } static bool par_and_goal_is_safe_test(pl_program *prog, const pl_term *goal, const pl_env *env, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal) { return false; } if (goal->tag == PL_TERM_ATOM) { if (!goal->v.atom_name) { return false; } if (!strcmp(goal->v.atom_name, "true") || !strcmp(goal->v.atom_name, "fail") || !strcmp(goal->v.atom_name, "false")) { return true; } if (builtin_pred_defined(goal->v.atom_name, 0)) { return false; } if (prog_tabled_pred_contains(prog, goal->v.atom_name, 0)) { return false; } prog_par_and_safety_ensure(prog, rt_ctrl, dbg_dat_ptr); if (prog && prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, goal->v.atom_name, 0); return e && e->and_safe; } return false; } if (goal->tag != PL_TERM_STRUCT) { return false; } const CHR *fn = goal->v.str.functor; const ULO ar = goal->v.str.arity; if (!fn) { return false; } // Mode-sensitive safe set: allow some traditionally nondet predicates only in semidet/det modes. if ((ar == 2) && !strcmp(fn, "length")) { pl_term *list = deref_term(goal->v.str.args[0], env); pl_term *len = deref_term(goal->v.str.args[1], env); if (!list || !len) { return false; } // length/2 becomes a generator when both arguments are variables. return !((list->tag == PL_TERM_VAR) && (len->tag == PL_TERM_VAR)); } if ((ar == 3) && !strcmp(fn, "atom_concat")) { pl_term *a = deref_term(goal->v.str.args[0], env); pl_term *b = deref_term(goal->v.str.args[1], env); pl_term *c = deref_term(goal->v.str.args[2], env); if (!a || !b || !c) { return false; } // atom_concat/3 enumerates splits only when both A and B are variables and C is an atom. return !((c->tag == PL_TERM_ATOM) && (a->tag == PL_TERM_VAR) && (b->tag == PL_TERM_VAR)); } if ((ar == 5) && (!strcmp(fn, "sub_atom") || !strcmp(fn, "sub_string"))) { pl_term *a = deref_term(goal->v.str.args[0], env); pl_term *before = deref_term(goal->v.str.args[1], env); pl_term *len = deref_term(goal->v.str.args[2], env); pl_term *after = deref_term(goal->v.str.args[3], env); pl_term *sub = deref_term(goal->v.str.args[4], env); if (!a || !before || !len || !after || !sub) { return false; } // If the source isn't an atom, execution is deterministic (it will throw or fail). if (a->tag != PL_TERM_ATOM) { return true; } const int idx_var = (before->tag == PL_TERM_VAR ? 1 : 0) + (len->tag == PL_TERM_VAR ? 1 : 0) + (after->tag == PL_TERM_VAR ? 1 : 0); // With 0 or 1 free index, the substring position/length is fully determined (at most 1 solution). if (idx_var <= 1) { return true; } // When Sub is given and at least one boundary is fixed, this is semidet (Sub at a fixed/derived position). if ((sub->tag == PL_TERM_ATOM) && ((before->tag == PL_TERM_INT) || (after->tag == PL_TERM_INT))) { return true; } return false; } if (ar == 1) { if (!strcmp(fn, "var") || !strcmp(fn, "nonvar") || !strcmp(fn, "atom") || !strcmp(fn, "integer") || !strcmp(fn, "float") || !strcmp(fn, "number") || !strcmp(fn, "atomic") || !strcmp(fn, "compound") || !strcmp(fn, "callable") || !strcmp(fn, "ground") || !strcmp(fn, "acyclic_term") || !strcmp(fn, "$flowlog_sleep_ms")) { return true; } } else if (ar == 2) { if (!strcmp(fn, "=") || !strcmp(fn, "is") || !strcmp(fn, "==") || !strcmp(fn, "\\==") || !strcmp(fn, "\\=") || !strcmp(fn, "=@=") || !strcmp(fn, "\\=@=") || !strcmp(fn, "=:=") || !strcmp(fn, "=\\=") || !strcmp(fn, "<") || !strcmp(fn, "=<") || !strcmp(fn, ">") || !strcmp(fn, ">=") || !strcmp(fn, "@<") || !strcmp(fn, "@=<") || !strcmp(fn, "@>") || !strcmp(fn, "@>=") || !strcmp(fn, "=..") || !strcmp(fn, "unify_with_occurs_check") || !strcmp(fn, "subsumes_term") || !strcmp(fn, "copy_term") || !strcmp(fn, "term_variables") || !strcmp(fn, "atom_length") || !strcmp(fn, "atom_chars") || !strcmp(fn, "atom_codes") || !strcmp(fn, "number_chars") || !strcmp(fn, "number_codes") || !strcmp(fn, "char_code") || !strcmp(fn, "sort") || !strcmp(fn, "keysort") || !strcmp(fn, "succ")) { return true; } } else if (ar == 3) { if (!strcmp(fn, "functor") || !strcmp(fn, "arg") || !strcmp(fn, "compare") || !strcmp(fn, "numbervars")) { return true; } } // AND-par "flow analysis": allow user predicates proven pure + semidet/det. if (!builtin_pred_defined(fn, ar)) { if (prog_tabled_pred_contains(prog, fn, ar)) { return false; } prog_par_and_safety_ensure(prog, rt_ctrl, dbg_dat_ptr); if (prog && prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, fn, ar); return e && e->and_safe; } } return false; } static bool par_and_goal_is_safe_test_wam(pl_program *prog, const pl_term *goal, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal) { return false; } if (goal->tag == PL_TERM_ATOM) { if (!goal->v.atom_name) { return false; } if (!strcmp(goal->v.atom_name, "true") || !strcmp(goal->v.atom_name, "fail") || !strcmp(goal->v.atom_name, "false")) { return true; } if (builtin_pred_defined(goal->v.atom_name, 0)) { return false; } if (prog_tabled_pred_contains(prog, goal->v.atom_name, 0)) { return false; } prog_par_and_safety_ensure(prog, rt_ctrl, dbg_dat_ptr); if (prog && prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, goal->v.atom_name, 0); return e && e->and_safe; } return false; } if (goal->tag != PL_TERM_STRUCT) { return false; } const CHR *fn = goal->v.str.functor; const ULO ar = goal->v.str.arity; if (!fn) { return false; } // Mode-sensitive safe set: allow some traditionally nondet predicates only in semidet/det modes. if ((ar == 2) && !strcmp(fn, "length")) { pl_term *list = deref_term_wam(goal->v.str.args[0]); pl_term *len = deref_term_wam(goal->v.str.args[1]); if (!list || !len) { return false; } // length/2 becomes a generator when both arguments are variables. return !((list->tag == PL_TERM_VAR) && (len->tag == PL_TERM_VAR)); } if ((ar == 3) && !strcmp(fn, "atom_concat")) { pl_term *a = deref_term_wam(goal->v.str.args[0]); pl_term *b = deref_term_wam(goal->v.str.args[1]); pl_term *c = deref_term_wam(goal->v.str.args[2]); if (!a || !b || !c) { return false; } // atom_concat/3 enumerates splits only when both A and B are variables and C is an atom. return !((c->tag == PL_TERM_ATOM) && (a->tag == PL_TERM_VAR) && (b->tag == PL_TERM_VAR)); } if ((ar == 5) && (!strcmp(fn, "sub_atom") || !strcmp(fn, "sub_string"))) { pl_term *a = deref_term_wam(goal->v.str.args[0]); pl_term *before = deref_term_wam(goal->v.str.args[1]); pl_term *len = deref_term_wam(goal->v.str.args[2]); pl_term *after = deref_term_wam(goal->v.str.args[3]); pl_term *sub = deref_term_wam(goal->v.str.args[4]); if (!a || !before || !len || !after || !sub) { return false; } // If the source isn't an atom, execution is deterministic (it will throw or fail). if (a->tag != PL_TERM_ATOM) { return true; } const int idx_var = (before->tag == PL_TERM_VAR ? 1 : 0) + (len->tag == PL_TERM_VAR ? 1 : 0) + (after->tag == PL_TERM_VAR ? 1 : 0); // With 0 or 1 free index, the substring position/length is fully determined (at most 1 solution). if (idx_var <= 1) { return true; } // When Sub is given and at least one boundary is fixed, this is semidet (Sub at a fixed/derived position). if ((sub->tag == PL_TERM_ATOM) && ((before->tag == PL_TERM_INT) || (after->tag == PL_TERM_INT))) { return true; } return false; } if (ar == 1) { if (!strcmp(fn, "var") || !strcmp(fn, "nonvar") || !strcmp(fn, "atom") || !strcmp(fn, "integer") || !strcmp(fn, "float") || !strcmp(fn, "number") || !strcmp(fn, "atomic") || !strcmp(fn, "compound") || !strcmp(fn, "callable") || !strcmp(fn, "ground") || !strcmp(fn, "acyclic_term") || !strcmp(fn, "$flowlog_sleep_ms")) { return true; } } else if (ar == 2) { if (!strcmp(fn, "=") || !strcmp(fn, "is") || !strcmp(fn, "==") || !strcmp(fn, "\\==") || !strcmp(fn, "\\=") || !strcmp(fn, "=@=") || !strcmp(fn, "\\=@=") || !strcmp(fn, "=:=") || !strcmp(fn, "=\\=") || !strcmp(fn, "<") || !strcmp(fn, "=<") || !strcmp(fn, ">") || !strcmp(fn, ">=") || !strcmp(fn, "@<") || !strcmp(fn, "@=<") || !strcmp(fn, "@>") || !strcmp(fn, "@>=") || !strcmp(fn, "=..") || !strcmp(fn, "unify_with_occurs_check") || !strcmp(fn, "subsumes_term") || !strcmp(fn, "copy_term") || !strcmp(fn, "term_variables") || !strcmp(fn, "atom_length") || !strcmp(fn, "atom_chars") || !strcmp(fn, "atom_codes") || !strcmp(fn, "number_chars") || !strcmp(fn, "number_codes") || !strcmp(fn, "char_code") || !strcmp(fn, "sort") || !strcmp(fn, "keysort") || !strcmp(fn, "succ")) { return true; } } else if (ar == 3) { if (!strcmp(fn, "functor") || !strcmp(fn, "arg") || !strcmp(fn, "compare") || !strcmp(fn, "numbervars")) { return true; } } // AND-par "flow analysis": allow user predicates proven pure + semidet/det. if (!builtin_pred_defined(fn, ar)) { if (prog_tabled_pred_contains(prog, fn, ar)) { return false; } prog_par_and_safety_ensure(prog, rt_ctrl, dbg_dat_ptr); if (prog && prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, fn, ar); return e && e->and_safe; } } return false; } static bool par_and_goal_is_spec_barrier(const pl_term *goal) { if (!goal) { return false; } if (goal->tag != PL_TERM_STRUCT) { return false; } const CHR *fn = goal->v.str.functor; const ULO ar = goal->v.str.arity; if (!fn) { return false; } // Global flag changes can affect otherwise "pure" built-ins (e.g. occurs_check affecting =/2), // so do not speculate across them. return (ar == 2) && !strcmp(fn, "set_prolog_flag"); } static bool par_goals_disjoint(pl_term *a, pl_term *b, const pl_env *env, const ULO *dbg_dat_ptr) { if (!a || !b) { return false; } pl_var_stack st; pl_var_list va; pl_var_list vb; var_stack_init(&st); var_list_init(&va); term_collect_vars_tr(a, env, &st, &va, dbg_dat_ptr, 0); var_stack_free(&st); var_stack_init(&st); var_list_init(&vb); term_collect_vars_tr(b, env, &st, &vb, dbg_dat_ptr, 0); var_stack_free(&st); bool disjoint = true; for (ULO i = 0; i < va.count; i++) { if (var_list_contains_key(&vb, va.items[i].key)) { disjoint = false; break; } } var_list_free(&va); var_list_free(&vb); return disjoint; } static void par_and_merge_delta(pl_env *dst, const pl_env *base, const pl_env *src, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!dst || !src) { return; } // `pl_env` is modeled as a parent chain (env_clone creates a new frame with parent=base). // Merge the bindings introduced between `base` (exclusive) and `src` (inclusive). if (src == base) { return; } const pl_env *chain[4096]; size_t chain_count = 0; const pl_env *cur = src; while (cur && (cur != base) && (chain_count < (sizeof(chain) / sizeof(chain[0])))) { chain[chain_count++] = cur; cur = cur->parent; } if (base && (cur != base)) { // `base` was not found as an ancestor (unexpected); fall back to merging only `src`'s local bindings. chain_count = 1; chain[0] = src; } for (size_t ei = chain_count; ei > 0; ei--) { const pl_env *e = chain[ei - 1]; if (!e || !e->items || !e->count) { continue; } for (ULO i = 0; i < e->count; i++) { const pl_binding *b = &e->items[i]; if (!b) { continue; } pl_term *val = b->value; if (val && (val->tag == PL_TERM_INT)) { val = make_int_rt(rt_ctrl, dbg_dat_ptr, val->v.int_value); } else if (val && (val->tag == PL_TERM_FLOAT)) { val = make_float_rt(rt_ctrl, dbg_dat_ptr, val->v.float_value); } env_bind(dst, rt_ctrl, dbg_dat_ptr, b->scope, b->var_id, val); } } } static pl_env *par_and_merge_env(const pl_env *base, const pl_env *const *envs, ULO env_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { bool need = false; for (ULO i = 0; i < env_count; i++) { const pl_env *e = envs ? envs[i] : NULL; if (e && (e != base)) { need = true; break; } } if (!need) { return (pl_env *)base; } pl_env *merged = env_clone(base, rt_ctrl, dbg_dat_ptr); for (ULO i = 0; i < env_count; i++) { const pl_env *e = envs ? envs[i] : NULL; if (!e) { continue; } par_and_merge_delta(merged, base, e, rt_ctrl, dbg_dat_ptr); } return merged; } static inline pl_term *bagof_existentials_next_tr(pl_term *g, const pl_env *env) { g = deref_term(g, env); if (!g || (g->tag != PL_TERM_STRUCT) || (g->v.str.arity != 2) || strcmp(g->v.str.functor, "^")) { return NULL; } return deref_term(g->v.str.args[1], env); } static inline pl_term *bagof_existentials_next_wam(pl_term *g) { g = deref_term_wam(g); if (!g || (g->tag != PL_TERM_STRUCT) || (g->v.str.arity != 2) || strcmp(g->v.str.functor, "^")) { return NULL; } return deref_term_wam(g->v.str.args[1]); } static pl_term *strip_bagof_existentials(pl_term *goal, const pl_env *env, pl_var_list *exist, const ULO *dbg_dat_ptr) { pl_term *g = deref_term(goal, env); pl_term *slow = g; pl_term *fast = g; while (1) { if (!g || (g->tag != PL_TERM_STRUCT) || (g->v.str.arity != 2) || strcmp(g->v.str.functor, "^")) { break; } pl_term *v = deref_term(g->v.str.args[0], env); if (v && (v->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = v->v.var.scope, .var_id = v->v.var.var_id}; var_list_add_unique(exist, dbg_dat_ptr, k, v); } g = deref_term(g->v.str.args[1], env); slow = bagof_existentials_next_tr(slow, env); fast = bagof_existentials_next_tr(fast, env); if (fast) { fast = bagof_existentials_next_tr(fast, env); } if (slow && fast && slow == fast) { break; } } return g; } static pl_term *strip_bagof_existentials_wam(pl_term *goal, pl_var_list *exist, const ULO *dbg_dat_ptr) { pl_term *g = deref_term_wam(goal); pl_term *slow = g; pl_term *fast = g; while (1) { if (!g || (g->tag != PL_TERM_STRUCT) || (g->v.str.arity != 2) || strcmp(g->v.str.functor, "^")) { break; } pl_term *v = deref_term_wam(g->v.str.args[0]); if (v && (v->tag == PL_TERM_VAR)) { pl_var_key k = {.scope = v->v.var.scope, .var_id = v->v.var.var_id}; var_list_add_unique(exist, dbg_dat_ptr, k, v); } g = deref_term_wam(g->v.str.args[1]); slow = bagof_existentials_next_wam(slow); fast = bagof_existentials_next_wam(fast); if (fast) { fast = bagof_existentials_next_wam(fast); } if (slow && fast && slow == fast) { break; } } return g; } typedef struct { pl_term *template; pl_env *env_out; pl_temp_alloc alloc; pl_term_vec results; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_findall_ctx; static void findall_on_solution(const pl_env *env, void *ctx0) { pl_findall_ctx *ctx = (pl_findall_ctx *)ctx0; if (!ctx || !ctx->template || !ctx->env_out) { return; } // Capture result terms in a separate temp allocator so they are not freed by // per-choicepoint temp releases in the generating goal. pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &ctx->alloc; pl_scope *scope = (pl_scope *)pool_alloc(ctx->rt_ctrl, sizeof(*scope), ctx->dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *inst = copy_term_tr(ctx->template, env, ctx->env_out, &m, ctx->rt_ctrl, ctx->dbg_dat_ptr, 0); copy_var_map_free(&m); g_temp_alloc = saved_tmp; if (!inst) { return; } term_vec_push(&ctx->results, ctx->dbg_dat_ptr, inst); } typedef struct { pl_term *term; pl_scope *scope; // scope holding the term's copied variables ULO var_count; // number of variables in the scope (0..var_count-1) pl_term **bindings; // initial bindings for copied vars (may be NULL) } pl_findall_wam_item; typedef struct { pl_findall_wam_item *items; ULO count; ULO cap; } pl_findall_wam_vec; static void findall_wam_vec_init(pl_findall_wam_vec *v) { memset(v, 0, sizeof(*v)); } static void findall_wam_vec_free(pl_findall_wam_vec *v) { free(v->items); memset(v, 0, sizeof(*v)); } static void findall_wam_vec_push(pl_findall_wam_vec *v, const ULO *dbg_dat_ptr, pl_findall_wam_item it) { if (!v) { return; } if (v->count == v->cap) { ULO new_cap = v->cap ? (v->cap * 2) : 16; pl_findall_wam_item *new_items = (pl_findall_wam_item *)realloc(v->items, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } v->items = new_items; v->cap = new_cap; } v->items[v->count++] = it; } typedef struct { pl_term *template; pl_findall_wam_vec results; pl_temp_alloc alloc; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_findall_wam_ctx; static void findall_wam_on_solution(pl_wam_state *st, void *ctx0, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)st; (void)rt_ctrl; (void)dbg_dat_ptr; pl_findall_wam_ctx *ctx = (pl_findall_wam_ctx *)ctx0; if (!ctx || !ctx->template) { return; } // Capture result terms in a separate temp allocator so they are not freed by // per-choicepoint temp releases in the generating goal. pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &ctx->alloc; pl_scope *scope = (pl_scope *)pool_alloc(ctx->rt_ctrl, sizeof(*scope), ctx->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx; memset(&cctx, 0, sizeof(cctx)); cctx.rt_ctrl = ctx->rt_ctrl; cctx.dbg_dat_ptr = ctx->dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *inst = copy_term_wam_tr(ctx->template, &cctx, 0); const ULO var_count = cctx.map.next_var_id; copy_var_map_free(&cctx.map); g_temp_alloc = saved_tmp; if (!inst) { free(cctx.bindings); return; } findall_wam_vec_push(&ctx->results, ctx->dbg_dat_ptr, (pl_findall_wam_item){.term = inst, .scope = scope, .var_count = var_count, .bindings = cctx.bindings}); } typedef struct { pl_term *key; pl_term *term; pl_scope *scope; // scope holding the copied variables ULO var_count; // number of variables in the scope (0..var_count-1) pl_term **bindings; // initial bindings for copied vars (may be NULL) } pl_bagof_wam_item; typedef struct { pl_bagof_wam_item *items; ULO count; ULO cap; } pl_bagof_wam_vec; static void bagof_wam_vec_init(pl_bagof_wam_vec *v) { memset(v, 0, sizeof(*v)); } static void bagof_wam_vec_free(pl_bagof_wam_vec *v) { free(v->items); memset(v, 0, sizeof(*v)); } static void bagof_wam_vec_push(pl_bagof_wam_vec *v, const ULO *dbg_dat_ptr, pl_bagof_wam_item it) { if (!v) { return; } if (v->count == v->cap) { ULO new_cap = v->cap ? (v->cap * 2) : 16; pl_bagof_wam_item *new_items = (pl_bagof_wam_item *)realloc(v->items, sizeof(*new_items) * new_cap); if (!new_items) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } v->items = new_items; v->cap = new_cap; } v->items[v->count++] = it; } typedef struct { pl_term *key; pl_term *template; pl_bagof_wam_vec results; pl_temp_alloc alloc; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_bagof_wam_ctx; static void bagof_wam_on_solution(pl_wam_state *st, void *ctx0, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)st; (void)rt_ctrl; (void)dbg_dat_ptr; pl_bagof_wam_ctx *ctx = (pl_bagof_wam_ctx *)ctx0; if (!ctx || !ctx->key || !ctx->template) { return; } // Capture result terms in a separate temp allocator so they are not freed by // per-choicepoint temp releases in the generating goal. pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &ctx->alloc; pl_scope *scope = (pl_scope *)pool_alloc(ctx->rt_ctrl, sizeof(*scope), ctx->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx; memset(&cctx, 0, sizeof(cctx)); cctx.rt_ctrl = ctx->rt_ctrl; cctx.dbg_dat_ptr = ctx->dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *key_inst = copy_term_wam_tr(ctx->key, &cctx, 0); pl_term *templ_inst = copy_term_wam_tr(ctx->template, &cctx, 0); const ULO var_count = cctx.map.next_var_id; copy_var_map_free(&cctx.map); g_temp_alloc = saved_tmp; if (!key_inst || !templ_inst) { free(cctx.bindings); return; } bagof_wam_vec_push(&ctx->results, ctx->dbg_dat_ptr, (pl_bagof_wam_item){.key = key_inst, .term = templ_inst, .scope = scope, .var_count = var_count, .bindings = cctx.bindings}); } typedef struct { pl_term *key; pl_term *template; pl_env *env_out; pl_temp_alloc alloc; pl_solution_group_vec groups; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_bagof_ctx; static void bagof_on_solution(const pl_env *env, void *ctx0) { pl_bagof_ctx *ctx = (pl_bagof_ctx *)ctx0; if (!ctx || !ctx->key || !ctx->template || !ctx->env_out) { return; } // Capture result terms in a separate temp allocator so they are not freed by // per-choicepoint temp releases in the generating goal. pl_temp_alloc *saved_tmp = g_temp_alloc; g_temp_alloc = &ctx->alloc; pl_scope *scope = (pl_scope *)pool_alloc(ctx->rt_ctrl, sizeof(*scope), ctx->dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *key_copy = copy_term_tr(ctx->key, env, ctx->env_out, &m, ctx->rt_ctrl, ctx->dbg_dat_ptr, 0); pl_term *templ_copy = copy_term_tr(ctx->template, env, ctx->env_out, &m, ctx->rt_ctrl, ctx->dbg_dat_ptr, 0); copy_var_map_free(&m); g_temp_alloc = saved_tmp; if (!key_copy || !templ_copy) { return; } for (ULO i = 0; i < ctx->groups.count; i++) { pl_solution_group *g = &ctx->groups.items[i]; if (!g->key) { continue; } if (!term_variant_env(key_copy, g->key, ctx->env_out, ctx->dbg_dat_ptr)) { continue; } if (unify_terms(key_copy, g->key, ctx->env_out, ctx->rt_ctrl, ctx->dbg_dat_ptr)) { term_vec_push(&g->templates, ctx->dbg_dat_ptr, templ_copy); return; } } pl_solution_group *g = group_vec_push(&ctx->groups, ctx->dbg_dat_ptr); g->key = key_copy; term_vec_push(&g->templates, ctx->dbg_dat_ptr, templ_copy); } static void trace_reset(void) { g_trace_depth = 0; g_trace_clause = NULL; g_argv_clause = NULL; g_itrace_last_depth = -1; g_trace_overflow = false; g_trace_overflow_depth = 0; g_trace_overflow_frame = (pl_trace_frame){0}; if (g_trace_frames && g_trace_frames_cap) { memset(g_trace_frames, 0, sizeof(pl_trace_frame) * (size_t)g_trace_frames_cap); } } static bool trace_goal_name_hidden_prolog(const CHR *name) { if (!name || !*name) { return true; } // Hide internal/reserved goals and trace control goals from the Prolog-style trace stream. if (name[0] == '$') { return true; } if (!strcmp(name, "trace") || !strcmp(name, "notrace") || !strcmp(name, "itrace") || !strcmp(name, "noitrace") || !strcmp(name, "debug") || !strcmp(name, "nodebug")) { return true; } return false; } static void trace_emit_internal(char prefix, ULO depth, const pl_trace_frame *f) { if (!f || !f->name) { return; } flowlog_cstack_init_once(); const size_t used = flowlog_cstack_used_bytes(); const pl_program *prog = g_current_prog; if (prog && prog->flag_itrace_watermark) { if (used <= g_itrace_watermark_max) { return; } g_itrace_watermark_max = used; } (void)fprintf(stderr, "%ci", prefix); if (used) { (void)fprintf(stderr, " s:%zu ", used); } (void)fprintf(stderr, "%1lu %s/%lu", (unsigned long)depth, f->name ? f->name : "?", (unsigned long)f->arity); if (f->src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)f->src_line, (unsigned long)f->src_col); } (void)fprintf(stderr, "\n"); } static void trace_emit_prolog_term(char prefix, ULO depth, const char *port, const pl_term *goal, const pl_env *env, const pl_clause *cl) { if (!goal || !port) { return; } pl_term *g = (pl_term *)goal; if (g_wam_state) { g = deref_term_wam(g); } else { g = deref_term(g, env); } const CHR *name = NULL; ULO arity = 0; if (g && (g->tag == PL_TERM_ATOM)) { name = g->v.atom_name; arity = 0; } else if (g && (g->tag == PL_TERM_STRUCT)) { name = g->v.str.functor; arity = g->v.str.arity; } else { return; } if (trace_goal_name_hidden_prolog(name)) { return; } if (builtin_pred_defined(name, arity)) { return; } pl_sbuf sb; sbuf_init(&sb, NULL, NULL); if (g_wam_state) { pl_var_stack st; var_stack_init(&st); term_to_sbuf_tr_wam(goal, &sb, &st, NULL, 0); var_stack_free(&st); } else { term_to_sbuf(goal, env, &sb, NULL); } (void)fprintf(stderr, "%cp %5lu %s %s", prefix, (unsigned long)depth, port, sb.buf ? sb.buf : ""); if (cl && cl->src_line) { (void)fprintf(stderr, " clause %lu:%lu", (unsigned long)cl->src_line, (unsigned long)cl->src_col); } (void)fprintf(stderr, "\n"); sbuf_free(&sb); } static void trace_emit_prolog_goal(char prefix, ULO depth, const char *port, const pl_term *goal, const pl_clause *cl) { trace_emit_prolog_term(prefix, depth, port, goal, NULL, cl); } static void trace_record_goal(const pl_program *prog, pl_term *raw_goal, const pl_env *env_in, ULO depth) { if (!prog) { return; } // This runs in the hot solver loop. Avoid deref/lookup work unless the user // explicitly enabled tracing. if (prog->flag_itrace) { const long last = g_itrace_last_depth; if (last >= 0 && (long)depth <= last) { long start = trace_storage_top_for_depth((ULO)last); if (start < 0) { start = -1; } long end = (long)depth; if (start >= 0 && end > start) { end = start; } if (end < 0) { end = 0; } for (long d = start; d >= end; d--) { const pl_trace_frame *prev = trace_frame_get((ULO)d); if (prev) { trace_emit_internal('<', (ULO)d, prev); } } } } pl_term *g = raw_goal; if ((prog->flag_trace || prog->flag_debug || prog->flag_itrace) && raw_goal) { g = deref_term(raw_goal, env_in); } const CHR *name = NULL; ULO arity = 0; if (g && (g->tag == PL_TERM_ATOM)) { name = g->v.atom_name; arity = 0; } else if (g && (g->tag == PL_TERM_STRUCT)) { name = g->v.str.functor; arity = g->v.str.arity; } else if (g && (g->tag == PL_TERM_VAR)) { name = ""; arity = 0; } else { name = ""; arity = 0; } g_trace_depth = depth; const ULO src_line = g_trace_clause ? g_trace_clause->src_line : 0; const ULO src_col = g_trace_clause ? g_trace_clause->src_col : 0; const pl_trace_frame *emit_frame = NULL; pl_trace_frame local_frame = {0}; if (trace_frame_ensure_slot(depth)) { g_trace_overflow = false; g_trace_overflow_depth = 0; g_trace_overflow_frame = (pl_trace_frame){0}; pl_trace_frame *slot = trace_frame_get_mut(depth); if (slot) { slot->name = name; slot->arity = arity; slot->src_line = src_line; slot->src_col = src_col; slot->goal = raw_goal; emit_frame = slot; } } if (!emit_frame) { g_trace_overflow = true; g_trace_overflow_depth = depth; g_trace_overflow_frame = (pl_trace_frame){ .name = name, .arity = arity, .src_line = src_line, .src_col = src_col, .goal = raw_goal, }; emit_frame = &g_trace_overflow_frame; } local_frame = *emit_frame; flowlog_cstack_note(depth); if (prog->flag_itrace) { trace_emit_internal('>', depth, &local_frame); g_itrace_last_depth = (long)depth; } if (prog->flag_trace) { if (g && (g->tag == PL_TERM_ATOM || g->tag == PL_TERM_STRUCT)) { trace_emit_prolog_term('>', depth, "CALL", raw_goal, env_in, NULL); } } } static void trace_record_goal_wam(const pl_program *prog, pl_term *raw_goal, ULO depth) { if (!prog) { return; } // This runs in the hot solver loop. Avoid deref/lookup work unless the user // explicitly enabled tracing or debugging output. if (prog->flag_itrace) { const long last = g_itrace_last_depth; if (last >= 0 && (long)depth <= last) { long start = trace_storage_top_for_depth((ULO)last); if (start < 0) { start = -1; } long end = (long)depth; if (start >= 0 && end > start) { end = start; } if (end < 0) { end = 0; } for (long d = start; d >= end; d--) { const pl_trace_frame *prev = trace_frame_get((ULO)d); if (prev) { trace_emit_internal('<', (ULO)d, prev); } } } } pl_term *g = raw_goal; if ((prog->flag_trace || prog->flag_debug || prog->flag_itrace) && raw_goal) { g = deref_term_wam(raw_goal); } const CHR *name = NULL; ULO arity = 0; if (g && (g->tag == PL_TERM_ATOM)) { name = g->v.atom_name; arity = 0; } else if (g && (g->tag == PL_TERM_STRUCT)) { name = g->v.str.functor; arity = g->v.str.arity; } else if (g && (g->tag == PL_TERM_VAR)) { name = ""; arity = 0; } else { name = ""; arity = 0; } g_trace_depth = depth; const ULO src_line = g_trace_clause ? g_trace_clause->src_line : 0; const ULO src_col = g_trace_clause ? g_trace_clause->src_col : 0; const pl_trace_frame *emit_frame = NULL; pl_trace_frame local_frame = {0}; if (trace_frame_ensure_slot(depth)) { g_trace_overflow = false; g_trace_overflow_depth = 0; g_trace_overflow_frame = (pl_trace_frame){0}; pl_trace_frame *slot = trace_frame_get_mut(depth); if (slot) { slot->name = name; slot->arity = arity; slot->src_line = src_line; slot->src_col = src_col; slot->goal = raw_goal; emit_frame = slot; } } if (!emit_frame) { g_trace_overflow = true; g_trace_overflow_depth = depth; g_trace_overflow_frame = (pl_trace_frame){ .name = name, .arity = arity, .src_line = src_line, .src_col = src_col, .goal = raw_goal, }; emit_frame = &g_trace_overflow_frame; } local_frame = *emit_frame; flowlog_cstack_note(depth); if (prog->flag_itrace) { trace_emit_internal('>', depth, &local_frame); g_itrace_last_depth = (long)depth; } if (prog->flag_trace) { if (g && (g->tag == PL_TERM_ATOM || g->tag == PL_TERM_STRUCT)) { trace_emit_prolog_term('>', depth, "CALL", raw_goal, NULL, NULL); } } } static void trace_print_stack(const pl_program *prog) { if (!prog || !(prog->flag_trace || prog->flag_itrace || prog->flag_debug)) { return; } const long top = trace_storage_top_for_depth(g_trace_depth); if (top < 0 && !(g_trace_overflow && g_trace_overflow_frame.name)) { return; } (void)fprintf(stderr, "Flowlog stack trace (most recent call first):\n"); for (long d = top; d >= 0; d--) { const pl_trace_frame *f = trace_frame_get((ULO)d); if (!f || !f->name) { continue; } (void)fprintf(stderr, " %s/%lu", f->name, (unsigned long)f->arity); if (f->src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)f->src_line, (unsigned long)f->src_col); } (void)fprintf(stderr, "\n"); } if (g_trace_overflow && g_trace_overflow_frame.name && (!g_trace_frames || (g_trace_overflow_depth >= g_trace_frames_cap))) { (void)fprintf(stderr, " (trace overflow: %s/%lu", g_trace_overflow_frame.name, (unsigned long)g_trace_overflow_frame.arity); if (g_trace_overflow_frame.src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)g_trace_overflow_frame.src_line, (unsigned long)g_trace_overflow_frame.src_col); } (void)fprintf(stderr, " depth=%lu)\n", (unsigned long)g_trace_overflow_depth); } if (g_cstack_peak.used_bytes) { (void)fprintf(stderr, "Flowlog c_stack peak: max=%zu depth=%lu\n", g_cstack_peak.used_bytes, (unsigned long)g_cstack_peak.depth); if (g_cstack_peak.overflow_valid && g_cstack_peak.overflow.name) { (void)fprintf(stderr, " peak_frame: %s/%lu", g_cstack_peak.overflow.name, (unsigned long)g_cstack_peak.overflow.arity); if (g_cstack_peak.overflow.src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)g_cstack_peak.overflow.src_line, (unsigned long)g_cstack_peak.overflow.src_col); } (void)fprintf(stderr, "\n"); } for (unsigned i = 0; i < g_cstack_peak.top_count && i < 5; i++) { const pl_trace_brief_frame *pf = &g_cstack_peak.top[i]; if (!pf->name) { continue; } (void)fprintf(stderr, " peak_stack_top: %s/%lu", pf->name, (unsigned long)pf->arity); if (pf->src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)pf->src_line, (unsigned long)pf->src_col); } (void)fprintf(stderr, "\n"); } } } static void flowlog_siginfo_report(void) { // Status output is intentionally written to stderr (user_error) so it remains // visible even when user_output is captured for deterministic solution output. // // Users may press Ctrl-C shortly after Ctrl-T; avoid SIGINT interrupting stdio // writes mid-report (which can leave FILE streams in an error state and drop // subsequent output). sigset_t old_mask; bool have_old_mask = false; sigset_t block; (void)sigemptyset(&block); (void)sigaddset(&block, SIGINT); if (pthread_sigmask(SIG_BLOCK, &block, &old_mask) == 0) { have_old_mask = true; } const pl_program *prog = g_current_prog; const CHR *prog_path = g_loaded_program_path ? g_loaded_program_path : "[user]"; const ULO ncpu = get_n_cpuproc(); const uint64_t phys = flowlog_phys_mem_bytes(); const ULO depth_real = g_trace_depth; const long depth_idx = trace_storage_top_for_depth(depth_real); const pl_trace_frame *f = (depth_idx >= 0) ? trace_frame_get((ULO)depth_idx) : NULL; if (g_trace_overflow && (g_trace_overflow_depth == depth_real) && g_trace_overflow_frame.name) { f = &g_trace_overflow_frame; } const char *pred_name = (f && f->name) ? f->name : "?"; const unsigned long pred_arity = (f && f->name) ? (unsigned long)f->arity : 0ul; const unsigned long src_line = (f && f->name) ? (unsigned long)f->src_line : 0ul; const unsigned long src_col = (f && f->name) ? (unsigned long)f->src_col : 0ul; const int max_threads = g_par_state ? g_par_state->max_threads : 1; const int budget = g_par_state ? atomic_load(&g_par_state->budget) : 0; flowlog_cstack_init_once(); const size_t cstack_used = flowlog_cstack_used_bytes(); const size_t cstack_max = g_cstack_max; const unsigned long cstack_max_depth = (unsigned long)g_cstack_max_trace_depth; (void)fputc('\n', stderr); (void)fprintf(stderr, "Flowlog SIGINFO (status)\n"); (void)fprintf(stderr, " program: %s\n", prog_path ? prog_path : "[user]"); (void)fprintf(stderr, " predicate: %s/%lu", pred_name ? pred_name : "?", pred_arity); if (src_line) { (void)fprintf(stderr, " at %lu:%lu", src_line, src_col); } (void)fprintf(stderr, " (depth=%lu)\n", (unsigned long)depth_real); if (prog) { const char *or_order = (prog->flag_parallel_or_order == PL_OR_UNORDERED) ? "unordered" : "ordered"; (void)fprintf(stderr, " parallel: or=%s (%s), and=%s, max_depth=%ld, or_nesting=%ld\n", prog->flag_parallel_or ? "on" : "off", or_order, prog->flag_parallel_and ? "on" : "off", (long)prog->flag_parallel_max_depth, (long)prog->flag_parallel_or_nesting); } (void)fprintf(stderr, " threads: cpus=%lu par_max=%d par_budget=%d orpar_worker=%s orpar_level=%d\n", (unsigned long)ncpu, max_threads, budget, g_orpar_thread_worker ? "yes" : "no", g_orpar_level); if (cstack_used || cstack_max) { (void)fprintf(stderr, " c_stack: used=%zu max=%zu max_depth=%lu\n", cstack_used, cstack_max, cstack_max_depth); } if (g_last_tc_start_ok || g_last_tc_worker_count || g_last_tc_cp_mask) { (void)fprintf(stderr, " last_orpar: workers=%lu cp_mask=0x%llx start_ok=%d\n", (unsigned long)g_last_tc_worker_count, (unsigned long long)g_last_tc_cp_mask, g_last_tc_start_ok); if (!g_last_tc_start_ok && g_last_tc_start_err_text[0]) { (void)fprintf(stderr, " last_orpar_error: %s\n", g_last_tc_start_err_text); } } if (g_temp_alloc) { const pl_temp_alloc *ta = g_temp_alloc; (void)fprintf(stderr, " temp_alloc: pool_ptrs=%zu malloc_ptrs=%zu shm_descrs=%zu arena=%zu/%zu\n", ta->pool_count, ta->malloc_count, ta->descr_count, ta->arena_off, ta->arena_cur_size); } if (g_table_state) { (void)fprintf(stderr, " tabling: subgoals=%lu stack=%lu\n", (unsigned long)g_table_state->sub_count, (unsigned long)g_table_state->stack_count); } if (phys) { const unsigned long long mib = (unsigned long long)(phys / (1024ull * 1024ull)); (void)fprintf(stderr, " system: phys_mem=%llu MiB\n", mib); } // Print a few stack frames to give immediate context without flooding. (void)fprintf(stderr, " stack_top:\n"); unsigned shown = 0; if (g_trace_overflow && (g_trace_overflow_depth == depth_real) && g_trace_overflow_frame.name) { (void)fprintf(stderr, " %s/%lu", g_trace_overflow_frame.name, (unsigned long)g_trace_overflow_frame.arity); if (g_trace_overflow_frame.src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)g_trace_overflow_frame.src_line, (unsigned long)g_trace_overflow_frame.src_col); } (void)fprintf(stderr, " (depth=%lu)\n", (unsigned long)depth_real); shown++; } for (long d = depth_idx; d >= 0 && shown < 5; d--) { const pl_trace_frame *sf = trace_frame_get((ULO)d); if (!sf || !sf->name) { continue; } (void)fprintf(stderr, " %s/%lu", sf->name, (unsigned long)sf->arity); if (sf->src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)sf->src_line, (unsigned long)sf->src_col); } (void)fprintf(stderr, "\n"); shown++; } if (g_cstack_peak.used_bytes) { (void)fprintf(stderr, " stack_peak:\n"); if (g_cstack_peak.overflow_valid && g_cstack_peak.overflow.name) { (void)fprintf(stderr, " %s/%lu", g_cstack_peak.overflow.name, (unsigned long)g_cstack_peak.overflow.arity); if (g_cstack_peak.overflow.src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)g_cstack_peak.overflow.src_line, (unsigned long)g_cstack_peak.overflow.src_col); } (void)fprintf(stderr, " (depth=%lu)\n", (unsigned long)g_cstack_peak.depth); } for (unsigned i = 0; i < g_cstack_peak.top_count && i < 5; i++) { const pl_trace_brief_frame *pf = &g_cstack_peak.top[i]; if (!pf->name) { continue; } (void)fprintf(stderr, " %s/%lu", pf->name, (unsigned long)pf->arity); if (pf->src_line) { (void)fprintf(stderr, " at %lu:%lu", (unsigned long)pf->src_line, (unsigned long)pf->src_col); } (void)fprintf(stderr, "\n"); } } (void)fflush(stderr); if (have_old_mask) { (void)pthread_sigmask(SIG_SETMASK, &old_mask, NULL); } } /* ============================================================================ * SECTION 22: Interpreter Solver & Builtins * tree-walking solver and builtin dispatch. * ============================================================================ */ /* --- SUBSECTION 22.1: Solver Core ---------------------------------------- */ // Interpreter solver core. // solve_goals_cb() and solve_goals_try_parallel_and() drive goal execution, meta-call, and AND-par splitting. typedef struct { pl_program *prog; const pl_query *q; pl_on_solution_fn on_solution; void *on_solution_ctx; const void *rt_ctrl; const ULO *dbg_dat_ptr; } pl_solve_tls_state; static FLOWLOG_TLS pl_solve_tls_state g_solve_tls = {0}; #ifndef FLOWLOG_NOINLINE #if defined(__GNUC__) || defined(__clang__) #define FLOWLOG_NOINLINE __attribute__((noinline)) #else #define FLOWLOG_NOINLINE #endif #endif static FLOWLOG_NOINLINE bool solve_goals_try_parallel_and(pl_cut_signal *out_sig, pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr); /* --- SUBSECTION 22.2: Builtin Dispatch Helpers --------------------------- */ // Builtin dispatch helpers for interpreter solver. // solve_goals_builtin_* handle read/write builtins and output capture without duplicating solver logic. static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_read(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr); static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_read_term(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr); static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_write(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr); static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_writeq(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr); static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_write_canonical(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr); static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_write_term(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr); static pl_cut_signal solve_goals_tls(pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count) { pl_program *prog = g_solve_tls.prog; const pl_query *q = g_solve_tls.q; pl_on_solution_fn on_solution = g_solve_tls.on_solution; void *on_solution_ctx = g_solve_tls.on_solution_ctx; const void *rt_ctrl = g_solve_tls.rt_ctrl; const ULO *dbg_dat_ptr = g_solve_tls.dbg_dat_ptr; #define solve_goals(prog, q, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, \ rt_ctrl, dbg_dat_ptr) \ solve_goals_tls(goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count) if (stop_at_first && *sol_count) { return cut_none(); } { const pl_cut_signal lim = flowlog_inference_limit_tick(exc_barrier, rt_ctrl, dbg_dat_ptr); if (lim.except) { return lim; } } if (flowlog_cancelled()) { return cut_none(); } if (goal_count == 0) { if (on_solution) { on_solution_lock(); on_solution(env_in, on_solution_ctx); on_solution_unlock(); } if (out) { if (g_solution_capture && g_solution_capture->out == out) { const size_t start = out->len; env_to_sbuf(q, env_in, out, dbg_dat_ptr); (void)solution_capture_mark(out, start); } else { if (*sol_count) { sbuf_append_cstr(out, "\n; "); } else { sbuf_append_cstr(out, " "); } env_to_sbuf(q, env_in, out, dbg_dat_ptr); } } (*sol_count)++; return cut_none(); } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_SOLVE_DEPTH_LIMIT)) { return cut_none(); } trace_record_goal(prog, goals ? goals[0] : NULL, env_in, depth); if (prog && g_par_state && prog->flag_parallel_and && (prog->flag_parallel_max_depth > 0) && ((SLO)depth < prog->flag_parallel_max_depth) && (goal_count >= 2)) { pl_cut_signal par_sig = cut_none(); if (solve_goals_try_parallel_and(&par_sig, prog, q, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr)) { return par_sig; } } pl_term *raw_goal = goals[0]; if (raw_goal && (raw_goal->tag == PL_TERM_VAR)) { // ISO: calling an unbound variable goal is an instantiation error. pl_term *d = deref_term_and_peel_pstr_empty(raw_goal, env_in); if (d && (d->tag == PL_TERM_VAR)) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (d && !term_is_callable_like(d)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", d, env_in, "call", 1); } // ISO: executing a variable goal is meta-call (equivalent to call(Var)). pl_term *call_goal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "call", 1); call_goal->v.str.args[0] = raw_goal; const ULO rest = goal_count - 1; const ULO new_goal_count = 1 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = call_goal; for (ULO i = 1; i < goal_count; i++) { new_goals[i] = goals[i]; } return solve_goals(prog, q, new_goals, new_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } pl_term *goal = deref_term_and_peel_pstr_empty(raw_goal, env_in); if (!goal) { return cut_none(); } // ISO: calling a non-callable term (e.g. a number) is a type error. if (term_is_list_like_pair(goal) && !term_is_list_pair(goal)) { pl_term *h = NULL; pl_term *tail = NULL; if (!term_list_like_uncons_rt(goal, &h, &tail, rt_ctrl, dbg_dat_ptr) || !h || !tail) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, "call", 1); } pl_term *st = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); st->v.str.args[0] = h; st->v.str.args[1] = tail; goal = st; } if (!term_is_callable_like(goal)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, "call", 1); } // Minimal built-ins (ISO-adjacent): true/0 and fail/0. if (goal && (goal->tag == PL_TERM_ATOM)) { if (!strcmp(goal->v.atom_name, "true")) { return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "fail") || !strcmp(goal->v.atom_name, "false")) { return cut_none(); } if (!strcmp(goal->v.atom_name, "halt")) { g_halt_requested = true; g_halt_code = 0; return cut_to(&g_halt_barrier); } if (!strcmp(goal->v.atom_name, "trace")) { if (prog) { prog->flag_trace = true; prog->flag_debug = true; } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "notrace")) { if (prog) { prog->flag_trace = false; } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "itrace")) { if (prog) { prog->flag_itrace = true; prog->flag_debug = true; } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "noitrace")) { if (prog) { prog->flag_itrace = false; } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "debug")) { if (prog) { prog->flag_debug = true; } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "nodebug")) { if (prog) { prog->flag_debug = false; } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "!")) { pl_cut_signal r = solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.except) { return r; } if (r.cut && (r.target != cut_barrier)) { return r; } return cut_to(cut_barrier); } if (!strcmp(goal->v.atom_name, "repeat")) { for (;;) { if (flowlog_cancelled()) { return cut_none(); } pl_temp_mark m = temp_alloc_mark(g_temp_alloc); pl_cut_signal r = solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } temp_alloc_release(g_temp_alloc, m, rt_ctrl, dbg_dat_ptr); if (stop_at_first && *sol_count) { return cut_none(); } } } // ISO stream output helpers. if (!strcmp(goal->v.atom_name, "nl")) { streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr) || !s->writable) { return cut_none(); } stream_write_char(s, id, '\n'); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "flush_output")) { streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr) || !s->writable) { return cut_none(); } if (flowlog_capture_user_output_stream(id)) { stream_drain_user_output_capture_if_enabled(s, id, rt_ctrl, dbg_dat_ptr); } else { (void)fflush(s->fp); } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "listing")) { streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return cut_none(); } if (!s->writable) { pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "listing", 0); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "listing", 0); } const pl_clause **snap = NULL; ULO snap_count = 0; if (prog && prog->clauses && prog->clause_count) { prog_db_rlock(prog); snap = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(*snap) * prog->clause_count, dbg_dat_ptr); for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } snap[snap_count++] = cl; } prog_db_runlock(prog); } for (ULO i = 0; i < snap_count; i++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = snap[i]; if (!cl || !cl->head) { continue; } pl_temp_mark m = {0}; const bool release_temp = (g_temp_alloc != NULL); if (release_temp) { m = temp_alloc_mark(g_temp_alloc); } pl_term *t = cl->head; if (cl->body_count && cl->body) { pl_term **body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = cl->body[bi + 1]; } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); pl_term *rule = make_struct_rt(rt_ctrl, dbg_dat_ptr, ":-", 2); rule->v.str.args[0] = cl->head; rule->v.str.args[1] = body_term; t = rule; } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, t, cl->env, &wopts, &sb, dbg_dat_ptr); sbuf_append_char(&sb, '.'); sbuf_append_char(&sb, '\n'); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); if (release_temp) { temp_alloc_release(g_temp_alloc, m, rt_ctrl, dbg_dat_ptr); } } if (id != 1) { (void)fflush(s->fp); } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(goal->v.atom_name, "at_end_of_stream")) { streams_init(dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(g_streams.current_input, &s, dbg_dat_ptr) || !s->readable) { return cut_none(); } if (s->pushback_count) { return cut_none(); } int c = fgetc(s->fp); if (c == EOF) { return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); return cut_none(); } } // Minimal ISO-ish built-ins (functional notation supported, operator notation later): // =(A,B), \\=(A,B), ==(A,B), \\==(A,B) // var(X), nonvar(X), atom(X), integer(X), number(X), atomic(X), compound(X), callable(X) // call(G) // is(VarOrNum, Expr) with numeric Exprs like +(1,2), *(2,3), /(1,2), div, mod, rem, abs, sign, float // =:=(A,B), =\\=(A,B), <(A,B), =<(A,B), >(A,B), >=(A,B) if (goal && (goal->tag == PL_TERM_STRUCT)) { const CHR *fn = goal->v.str.functor; const ULO ar = goal->v.str.arity; // Fast dispatch for hot arithmetic/ordering built-ins using cached builtin ids. // This avoids scanning the full built-in chain for common numeric goals. switch ((pl_builtin_id)goal->builtin) { case PL_BI_TERM_LT_2: case PL_BI_TERM_LTE_2: case PL_BI_TERM_GT_2: case PL_BI_TERM_GTE_2: { pl_var_stack st; var_stack_init(&st); const int r = compare_std_terms(goal->v.str.args[0], goal->v.str.args[1], env_in, &st, dbg_dat_ptr, 0); var_stack_free(&st); bool ok = false; switch ((pl_builtin_id)goal->builtin) { case PL_BI_TERM_LT_2: ok = (r < 0); break; case PL_BI_TERM_LTE_2: ok = (r <= 0); break; case PL_BI_TERM_GT_2: ok = (r > 0); break; case PL_BI_TERM_GTE_2: ok = (r >= 0); break; default: break; } if (ok) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } case PL_BI_IS_2: { pl_number val = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex(goal->v.str.args[1], env_in, &val, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", "is", 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", "is", 2); } pl_term *rhs = num_to_term_rt(val, rt_ctrl, dbg_dat_ptr); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], rhs, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } case PL_BI_NUM_EQ_2: case PL_BI_NUM_NE_2: case PL_BI_NUM_LT_2: case PL_BI_NUM_LTE_2: case PL_BI_NUM_GT_2: case PL_BI_NUM_GTE_2: { pl_number a = {0}, b = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex(goal->v.str.args[0], env_in, &a, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[0], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[0], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", fn, 2); } memset(&aerr, 0, sizeof(aerr)); if (!eval_num_expr_ex(goal->v.str.args[1], env_in, &b, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", fn, 2); } bool ok = false; if (!num_is_float(a) && !num_is_float(b)) { const int cmp = num_cmp(a, b); switch ((pl_builtin_id)goal->builtin) { case PL_BI_NUM_EQ_2: ok = (cmp == 0); break; case PL_BI_NUM_NE_2: ok = (cmp != 0); break; case PL_BI_NUM_LT_2: ok = (cmp < 0); break; case PL_BI_NUM_LTE_2: ok = (cmp <= 0); break; case PL_BI_NUM_GT_2: ok = (cmp > 0); break; case PL_BI_NUM_GTE_2: ok = (cmp >= 0); break; default: break; } } else { const double da = num_as_double(a); const double db = num_as_double(b); switch ((pl_builtin_id)goal->builtin) { case PL_BI_NUM_EQ_2: ok = (da == db); break; case PL_BI_NUM_NE_2: ok = (da != db); break; case PL_BI_NUM_LT_2: ok = (da < db); break; case PL_BI_NUM_LTE_2: ok = (da <= db); break; case PL_BI_NUM_GT_2: ok = (da > db); break; case PL_BI_NUM_GTE_2: ok = (da >= db); break; default: break; } } if (ok) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } default: break; } if (!strcmp(fn, "$drop_barrier") && (ar == 1)) { const uint16_t trace_depth_plus1 = goal->reserved16; ULO trace_pred_depth = 0; const pl_trace_frame *trace_pred_frame = NULL; if (trace_depth_plus1) { trace_pred_depth = (ULO)(trace_depth_plus1 - 1u); trace_pred_frame = trace_frame_get(trace_pred_depth); } pl_term *bar = deref_term(goal->v.str.args[0], env_in); if (!bar || (bar->tag != PL_TERM_INT)) { return cut_none(); } const void *new_barrier = (const void *)(uintptr_t)bar->v.int_value; if (prog && prog->flag_trace && trace_depth_plus1 && trace_pred_frame && trace_pred_frame->goal) { trace_emit_prolog_term('<', trace_pred_depth, "EXIT", trace_pred_frame->goal, env_in, g_trace_clause); } pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env_in, new_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } if (prog && prog->flag_trace && trace_depth_plus1 && trace_pred_frame && trace_pred_frame->goal) { trace_emit_prolog_term('^', trace_pred_depth, "REDO", trace_pred_frame->goal, env_in, g_trace_clause); } return cut_none(); } if (!strcmp(fn, "$drop_exc_barrier") && (ar == 1)) { pl_term *bar = deref_term(goal->v.str.args[0], env_in); if (!bar || (bar->tag != PL_TERM_INT)) { return cut_none(); } const void *new_barrier = (const void *)(uintptr_t)bar->v.int_value; return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, new_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "$flowlog_sleep_ms") && (ar == 1)) { pl_term *ms_t = deref_term(goal->v.str.args[0], env_in); if (!ms_t) { return cut_none(); } if (ms_t->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "$flowlog_sleep_ms", 1); } if (ms_t->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", ms_t, env_in, "$flowlog_sleep_ms", 1); } if (ms_t->v.int_value < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", ms_t, env_in, "$flowlog_sleep_ms", 1); } // Keep it bounded to avoid absurd sleep values in case this is accidentally exposed. SLO ms = ms_t->v.int_value; if (ms > 600000) { ms = 600000; } usleep((useconds_t)((unsigned long)ms * 1000UL)); return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "$flowlog_inference_limit") && (ar == 1)) { pl_term *lim_t = deref_term(goal->v.str.args[0], env_in); if (!lim_t) { return cut_none(); } if (lim_t->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "$flowlog_inference_limit", 1); } if (lim_t->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", lim_t, env_in, "$flowlog_inference_limit", 1); } if (lim_t->v.int_value < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", lim_t, env_in, "$flowlog_inference_limit", 1); } flowlog_inference_limit_local_set((uint64_t)lim_t->v.int_value); return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "$flowlog_inference_limit_shared") && (ar == 1)) { pl_term *lim_t = deref_term(goal->v.str.args[0], env_in); if (!lim_t) { return cut_none(); } if (lim_t->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "$flowlog_inference_limit_shared", 1); } if (lim_t->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", lim_t, env_in, "$flowlog_inference_limit_shared", 1); } if (lim_t->v.int_value < 0) { return throw_domain_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", lim_t, env_in, "$flowlog_inference_limit_shared", 1); } flowlog_inference_limit_shared_set(g_par_state, (uint64_t)lim_t->v.int_value); return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "$await_and") && (ar == 2)) { pl_term *w = deref_term(goal->v.str.args[0], env_in); pl_term *idx = deref_term(goal->v.str.args[1], env_in); if (!w || !idx || (w->tag != PL_TERM_INT) || (idx->tag != PL_TERM_INT)) { return cut_none(); } pl_and_work *work = (pl_and_work *)(uintptr_t)w->v.int_value; const SLO idx_slo = idx->v.int_value; if (!work || !work->jobs || idx_slo <= 0 || (ULO)idx_slo > work->count) { return cut_none(); } pl_and_job *job = &work->jobs[(ULO)idx_slo - 1]; while (!atomic_load(&job->done)) { usleep(1000); } if (job->sig.except) { if (job->tmp_snapshot && g_par_state) { par_state_adopt_snapshot(g_par_state, job->tmp_snapshot); job->tmp_snapshot = NULL; } atomic_store(&work->cancel, 1); return job->sig; } if (job->sig.cut) { atomic_store(&work->cancel, 1); return job->sig; } if (!job->ok) { atomic_store(&work->cancel, 1); return cut_none(); } // Adopt any allocations made by the speculative job so bindings remain valid for the rest of the query. if (job->tmp_snapshot && g_par_state) { par_state_adopt_snapshot(g_par_state, job->tmp_snapshot); job->tmp_snapshot = NULL; } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); par_and_merge_delta(env1, job->env_in, job->env_out, rt_ctrl, dbg_dat_ptr); return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "$if_barrier") && (ar == 2)) { pl_term *sub_goal = deref_term(goal->v.str.args[0], env_in); pl_term *outer = deref_term(goal->v.str.args[1], env_in); if (!sub_goal || !outer || (outer->tag != PL_TERM_INT)) { return cut_none(); } pl_term *drop_to_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_to_outer->v.str.args[0] = outer; const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = sub_goal; new_goals[1] = drop_to_outer; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } int inner_barrier = 0; pl_cut_signal r = solve_goals(prog, q, new_goals, new_goal_count, env_in, &inner_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut && (r.target == &inner_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, "->") && (ar == 2)) { pl_term *if_goal = deref_term(goal->v.str.args[0], env_in); pl_term *then_goal = deref_term(goal->v.str.args[1], env_in); if (!if_goal || !then_goal) { return cut_none(); } int ite_barrier = 0; pl_term *ite_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)&ite_barrier); pl_term *if_barrier = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$if_barrier", 2); if_barrier->v.str.args[0] = if_goal; if_barrier->v.str.args[1] = ite_barrier_term; pl_term *cut_goal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "!"); pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)cut_barrier); pl_term *drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_outer->v.str.args[0] = outer_barrier_term; const ULO rest = goal_count - 1; const ULO new_goal_count = 4 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = if_barrier; new_goals[1] = cut_goal; new_goals[2] = drop_outer; new_goals[3] = then_goal; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 3] = goals[i]; } pl_cut_signal r = solve_goals(prog, q, new_goals, new_goal_count, env_in, &ite_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut && (r.target == &ite_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, "=") && (ar == 2)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], goal->v.str.args[1], env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "\\=") && (ar == 2)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal->v.str.args[0], goal->v.str.args[1], env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "==") && (ar == 2)) { if (term_identical_env(goal->v.str.args[0], goal->v.str.args[1], env_in)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "\\==") && (ar == 2)) { if (!term_identical_env(goal->v.str.args[0], goal->v.str.args[1], env_in)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "=@=") && (ar == 2)) { if (term_variant_env(goal->v.str.args[0], goal->v.str.args[1], env_in, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "\\=@=") && (ar == 2)) { if (!term_variant_env(goal->v.str.args[0], goal->v.str.args[1], env_in, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, ",") && (ar == 2)) { pl_term *g1 = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); pl_term *g2 = deref_term_and_peel_pstr_empty(goal->v.str.args[1], env_in); if (!g1 || !g2) { return cut_none(); } // ISO: If the first conjunct is a variable, raise instantiation_error. if (g1->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } // ISO: If a conjunct is a non-variable, non-callable term, raise type_error(callable, (G1,G2)). if (!term_is_callable_like(g1)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, ",", 2); } if ((g2->tag != PL_TERM_VAR) && !term_is_callable_like(g2)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, ",", 2); } const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); new_goals[0] = goal->v.str.args[0]; new_goals[1] = goal->v.str.args[1]; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } return solve_goals(prog, q, new_goals, new_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, ";") && (ar == 2)) { pl_term *g1 = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); pl_term *g2 = deref_term_and_peel_pstr_empty(goal->v.str.args[1], env_in); if (!g1 || !g2) { return cut_none(); } // ISO: If a branch is a variable, raise instantiation_error. if (g1->tag == PL_TERM_VAR || g2->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } // ISO: If a branch is a non-callable term, raise type_error(callable, (G1;G2)). if (!term_is_callable_like(g1)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, ";", 2); } if (!term_is_callable_like(g2)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, ";", 2); } // ISO if-then-else: (If -> Then ; Else) is parsed as ;(->(If,Then),Else). if ((g1->tag == PL_TERM_STRUCT) && !strcmp(g1->v.str.functor, "->") && (g1->v.str.arity == 2)) { pl_term *if_goal = deref_term_and_peel_pstr_empty(g1->v.str.args[0], env_in); pl_term *then_goal = deref_term_and_peel_pstr_empty(g1->v.str.args[1], env_in); if (!if_goal || !then_goal) { return cut_none(); } if (if_goal->tag == PL_TERM_VAR || then_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(if_goal)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, ";", 2); } if (!term_is_callable_like(then_goal)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, env_in, ";", 2); } int ite_barrier = 0; pl_term *ite_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)&ite_barrier); pl_term *if_barrier = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$if_barrier", 2); if_barrier->v.str.args[0] = if_goal; if_barrier->v.str.args[1] = ite_barrier_term; pl_term *cut_goal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "!"); pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)cut_barrier); pl_term *drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_outer->v.str.args[0] = outer_barrier_term; const ULO rest = goal_count - 1; const ULO then_goal_count = 4 + rest; pl_term **then_goals = NULL; if (then_goal_count) { then_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * then_goal_count, dbg_dat_ptr); } then_goals[0] = if_barrier; then_goals[1] = cut_goal; then_goals[2] = drop_outer; then_goals[3] = then_goal; for (ULO i = 1; i < goal_count; i++) { then_goals[i + 3] = goals[i]; } pl_cut_signal r = solve_goals(prog, q, then_goals, then_goal_count, env_in, &ite_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.except) { return r; } if (r.cut) { if (r.target == &ite_barrier) { return cut_none(); } return r; } const ULO else_goal_count = 1 + rest; pl_term **else_goals = NULL; if (else_goal_count) { else_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * else_goal_count, dbg_dat_ptr); } else_goals[0] = g2; for (ULO i = 1; i < goal_count; i++) { else_goals[i] = goals[i]; } return solve_goals(prog, q, else_goals, else_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } const ULO rest = goal_count - 1; const ULO new_goal_count = 1 + rest; pl_term **goals1 = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); pl_term **goals2 = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); goals1[0] = g1; goals2[0] = g2; for (ULO i = 1; i < goal_count; i++) { goals1[i] = goals[i]; goals2[i] = goals[i]; } pl_cut_signal r = solve_goals(prog, q, goals1, new_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } return solve_goals(prog, q, goals2, new_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "halt") && (ar == 1)) { pl_term *code = deref_term(goal->v.str.args[0], env_in); if (!code) { return cut_none(); } if (code->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (code->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code, env_in, "halt", 1); } g_halt_requested = true; g_halt_code = code->v.int_value; return cut_to(&g_halt_barrier); } if (!strcmp(fn, "\\+") && (ar == 1)) { pl_term *sub_goal = deref_term(goal->v.str.args[0], env_in); if (!sub_goal) { return cut_none(); } pl_term *sub_goals[1] = {sub_goal}; pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); ULO any = 0; int local_barrier = 0; pl_cut_signal r = solve_goals_cb(prog, q, sub_goals, 1, env1, &local_barrier, exc_barrier, depth + 1, true, NULL, &any, NULL, NULL, rt_ctrl, dbg_dat_ptr); if (r.except) { return r; } if (!any) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "once") && (ar == 1)) { pl_term *sub_goal = deref_term(goal->v.str.args[0], env_in); if (!sub_goal) { return cut_none(); } pl_term *sub_goals[1] = {sub_goal}; ULO inner_sol = 0; int local_barrier = 0; pl_once_ctx ctx = {0}; pl_cut_signal inner = solve_goals_cb(prog, q, sub_goals, 1, env_in, &local_barrier, exc_barrier, depth + 1, true, NULL, &inner_sol, once_on_solution, &ctx, rt_ctrl, dbg_dat_ptr); if (inner.except) { return inner; } if (inner.cut && (inner.target != &local_barrier)) { return inner; } if (!ctx.env) { return cut_none(); } return solve_goals(prog, q, goals + 1, goal_count - 1, ctx.env, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "call") && (ar == 1)) { pl_term *call_term = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (!call_term) { return cut_none(); } if (call_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(call_term)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", call_term, env_in, "call", 1); } // ISO: call/1 introduces a new cut boundary. Cuts in Goal must not cut outside call/1. int call_barrier = 0; pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)cut_barrier); pl_term *drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_outer->v.str.args[0] = outer_barrier_term; const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = freeze_bound_vars_rt(call_term, env_in, rt_ctrl, dbg_dat_ptr, 0); new_goals[1] = drop_outer; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } pl_cut_signal r = solve_goals(prog, q, new_goals, new_goal_count, env_in, &call_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.except) { return r; } if (r.cut && (r.target == &call_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, ":") && (ar == 2)) { pl_term *qual_goal = deref_term(goal->v.str.args[1], env_in); if (!qual_goal) { return cut_none(); } // Defer ISO meta-call errors (e.g., instantiation_error(callable)) to call/1. pl_term *call_goal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "call", 1); call_goal->v.str.args[0] = qual_goal; const ULO new_goal_count = 1 + (goal_count - 1); pl_term **new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); new_goals[0] = call_goal; for (ULO i = 1; i < goal_count; i++) { new_goals[i] = goals[i]; } return solve_goals(prog, q, new_goals, new_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "call") && (ar >= 2) && (ar <= 8)) { pl_term *closure = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (!closure) { return cut_none(); } if (closure->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(closure)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", closure, env_in, "call", ar); } pl_term *module_term = NULL; pl_term *base = closure; if ((closure->tag == PL_TERM_STRUCT) && !strcmp(closure->v.str.functor, ":") && (closure->v.str.arity == 2)) { module_term = deref_term(closure->v.str.args[0], env_in); base = deref_term_and_peel_pstr_empty(closure->v.str.args[1], env_in); if (!base) { return cut_none(); } if (base->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(base)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", base, env_in, "call", ar); } } const ULO extra_n = ar - 1; pl_term *expanded = NULL; if (base->tag == PL_TERM_ATOM) { expanded = make_struct_rt(rt_ctrl, dbg_dat_ptr, base->v.atom_name, extra_n); for (ULO i = 0; i < extra_n; i++) { expanded->v.str.args[i] = deref_term(goal->v.str.args[i + 1], env_in); } } else { pl_term *fname = NULL; SLO base_arity = 0; if (!term_functor_arity_rt(base, &fname, &base_arity, rt_ctrl, dbg_dat_ptr) || !fname || (fname->tag != PL_TERM_ATOM) || (base_arity <= 0)) { return cut_none(); } expanded = make_struct_rt(rt_ctrl, dbg_dat_ptr, fname->v.atom_name, (ULO)base_arity + extra_n); for (SLO i = 0; i < base_arity; i++) { pl_term *argi = NULL; if (!term_compound_arg_rt(base, i + 1, &argi, rt_ctrl, dbg_dat_ptr) || !argi) { return cut_none(); } expanded->v.str.args[i] = deref_term(argi, env_in); } for (ULO i = 0; i < extra_n; i++) { expanded->v.str.args[(ULO)base_arity + i] = deref_term(goal->v.str.args[i + 1], env_in); } } if (!expanded) { return cut_none(); } pl_term *call_goal = expanded; if (module_term) { pl_term *qual = make_struct_rt(rt_ctrl, dbg_dat_ptr, ":", 2); qual->v.str.args[0] = module_term; qual->v.str.args[1] = expanded; call_goal = qual; } const ULO new_goal_count = 1 + (goal_count - 1); pl_term **new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); new_goals[0] = call_goal; for (ULO i = 1; i < goal_count; i++) { new_goals[i] = goals[i]; } return solve_goals(prog, q, new_goals, new_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if ((!strcmp(fn, "call_with_inference_limit") || !strcmp(fn, "call_with_inference_limit_par")) && (ar == 3)) { const bool shared = !strcmp(fn, "call_with_inference_limit_par"); const CHR *pred_name = shared ? "call_with_inference_limit_par" : "call_with_inference_limit"; const CHR *limit_pred = shared ? "$flowlog_inference_limit_shared" : "$flowlog_inference_limit"; pl_term *sub_goal = deref_term(goal->v.str.args[0], env_in); pl_term *lim_t = deref_term(goal->v.str.args[1], env_in); if (!sub_goal || !lim_t) { return cut_none(); } if (sub_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (sub_goal->tag != PL_TERM_ATOM && sub_goal->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", sub_goal, env_in, pred_name, 3); } if (lim_t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (lim_t->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", lim_t, env_in, pred_name, 3); } if (lim_t->v.int_value < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", lim_t, env_in, pred_name, 3); } // call_with_inference_limit/[3,3-par] introduces a local cut boundary (like call/1). int local_barrier = 0; const pl_call_with_inference_limit_wrap w = build_call_with_inference_limit_wrap_rt(rt_ctrl, dbg_dat_ptr, limit_pred, sub_goal, lim_t->v.int_value, goal->v.str.args[2], cut_barrier); const ULO rest = goal_count - 1; const ULO new_goal_count = 3 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = w.set_limit; new_goals[1] = w.catch_goal; new_goals[2] = w.drop_outer; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 2] = goals[i]; } pl_parallel_state *saved_par = NULL; atomic_int *saved_budget = NULL; if (!shared) { // Inference limits are per-thread. Suppress internal OR/AND-par while running // the limited Goal so worker threads cannot bypass the cap. saved_par = g_par_state; saved_budget = g_par_budget; g_par_state = NULL; g_par_budget = NULL; } pl_cut_signal r = solve_goals(prog, q, new_goals, new_goal_count, env_in, &local_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (!shared) { g_par_state = saved_par; g_par_budget = saved_budget; } // Ensure the limit does not leak even if Goal fails or throws. if (shared) { flowlog_inference_limit_shared_clear(g_par_state); } flowlog_inference_limit_local_clear(); if (r.except) { return r; } if (r.cut && (r.target == &local_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, "throw") && (ar == 1)) { pl_term *t = deref_term(goal->v.str.args[0], env_in); if (!t) { return cut_none(); } if (t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "nonvar"); } pl_env *exc_env = (pl_env *)pool_alloc(rt_ctrl, sizeof(*exc_env), dbg_dat_ptr); memset(exc_env, 0, sizeof(*exc_env)); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *copy = copy_term_tr(goal->v.str.args[0], env_in, exc_env, &m, rt_ctrl, dbg_dat_ptr, 0); copy_var_map_free(&m); if (!copy) { return cut_none(); } return except_to(exc_barrier, copy, exc_env); } if (!strcmp(fn, "catch") && (ar == 3)) { pl_term *sub_goal = deref_term(goal->v.str.args[0], env_in); pl_term *recover_goal = deref_term(goal->v.str.args[2], env_in); if (!sub_goal || !recover_goal) { return cut_none(); } int local_exc_barrier = 0; pl_term *outer_exc_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)exc_barrier); pl_term *drop_exc = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_exc_barrier", 1); drop_exc->v.str.args[0] = outer_exc_term; const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = sub_goal; new_goals[1] = drop_exc; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } pl_cut_signal r = solve_goals(prog, q, new_goals, new_goal_count, env_in, cut_barrier, &local_exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.except && (r.target == &local_exc_barrier)) { // Caught an exception thrown from within Goal; try to unify with Catcher. pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); env_append(env1, r.except_env, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal->v.str.args[1], r.except_term, env1, rt_ctrl, dbg_dat_ptr)) { // Not caught: retarget to outer handler and propagate. r.target = exc_barrier; return r; } const ULO recover_goal_count = 1 + rest; pl_term **recover_goals = NULL; if (recover_goal_count) { recover_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * recover_goal_count, dbg_dat_ptr); } recover_goals[0] = recover_goal; for (ULO i = 1; i < goal_count; i++) { recover_goals[i] = goals[i]; } return solve_goals(prog, q, recover_goals, recover_goal_count, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (r.except && (r.target == exc_barrier)) { return r; } return r; } // ISO-ish stream predicates (core I/O). if (!strcmp(fn, "current_input") && (ar == 1)) { streams_init(dbg_dat_ptr); pl_term *st = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, g_streams.current_input); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], st, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "current_output") && (ar == 1)) { streams_init(dbg_dat_ptr); pl_term *st = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, g_streams.current_output); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], st, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "current_error") && (ar == 1)) { streams_init(dbg_dat_ptr); pl_term *st = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, 2); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], st, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "set_input") && (ar == 1)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_input", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_input", 1); } if (!s->readable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "set_input", 1); } streams_init(dbg_dat_ptr); g_streams.current_input = id; return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "set_output") && (ar == 1)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_output", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_output", 1); } if (!s->writable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "set_output", 1); } streams_init(dbg_dat_ptr); g_streams.current_output = id; return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "set_error") && (ar == 1)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_error", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_error", 1); } if (!s->writable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "set_error", 1); } // Trealla's set_error/1 currently validates but does not affect current_error/1. return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "set_stream") && (ar == 2)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_stream", 2); } streams_init(dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_stream", 2); } pl_term *opt = deref_term(goal->v.str.args[1], env_in); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_property"); } if (opt->tag != PL_TERM_STRUCT) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_property", opt, env_in, "set_stream", 2); } if (!strcmp(opt->v.str.functor, "alias") && (opt->v.str.arity >= 1)) { pl_term *alias_term = deref_term(opt->v.str.args[0], env_in); if (!alias_term) { return cut_none(); } if (alias_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (alias_term->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_property", opt, env_in, "set_stream", 2); } // Clear alias from any other stream, then set it on this stream. for (size_t i = 0; i < g_streams.cap; i++) { pl_stream *s2 = &g_streams.items[i]; if (!s2->open || !s2->alias) { continue; } if (!strcmp(s2->alias, alias_term->v.atom_name)) { free(s2->alias); s2->alias = NULL; } } free(s->alias); s->alias = strdup(alias_term->v.atom_name); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } // Known but immutable stream properties: fail without error. if ((opt->v.str.arity == 1) && (!strcmp(opt->v.str.functor, "type") || !strcmp(opt->v.str.functor, "mode") || !strcmp(opt->v.str.functor, "file_name") || !strcmp(opt->v.str.functor, "file_no") || !strcmp(opt->v.str.functor, "line_count") || !strcmp(opt->v.str.functor, "position") || !strcmp(opt->v.str.functor, "reposition") || !strcmp(opt->v.str.functor, "end_of_stream") || !strcmp(opt->v.str.functor, "eof_action") || !strcmp(opt->v.str.functor, "bom") || !strcmp(opt->v.str.functor, "encoding") || !strcmp(opt->v.str.functor, "newline"))) { return cut_none(); } // Unknown stream properties: fail. return cut_none(); } if (!strcmp(fn, "set_stream_position") && (ar == 2)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); pl_term *pos_term = deref_term(goal->v.str.args[1], env_in); if (!st_term || !pos_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_stream_position", 2); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "set_stream_position", 2); } const bool repositionable = s->repositionable; if (!repositionable) { if (pos_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "reposition,stream"); } return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "reposition", "stream", pos_term, env_in, "set_stream_position", 2); } if (pos_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_position"); } if (pos_term->tag != PL_TERM_INT) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_position", pos_term, env_in, "set_stream_position", 2); } const SLO pos = pos_term->v.int_value; if (pos < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "position", pos_term, env_in, "set_stream_position", 2); } if (!stream_set_position(s, (long)pos)) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "reposition", "stream", pos_term, env_in, "set_stream_position", 2); } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "stream_property") && (ar == 2)) { streams_init(dbg_dat_ptr); pl_term *st_term = deref_term(goal->v.str.args[0], env_in); pl_term *prop_term = deref_term(goal->v.str.args[1], env_in); if (!st_term || !prop_term) { return cut_none(); } const bool prop_is_var = (prop_term->tag == PL_TERM_VAR); const bool stream_is_var = (st_term->tag == PL_TERM_VAR); SLO fixed_id = -1; if (!stream_is_var) { if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &fixed_id)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "stream_property", 2); } pl_stream *s = NULL; if (!stream_lookup(fixed_id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "stream_property", 2); } // Trealla: aliases work for property lookup but do not enumerate. if ((st_term->tag == PL_TERM_ATOM) && prop_is_var) { return cut_none(); } } const size_t start = stream_is_var ? 0 : (size_t)fixed_id; const size_t end = stream_is_var ? g_streams.cap : ((size_t)fixed_id + 1); for (size_t i = start; i < end; i++) { const SLO id = (SLO)i; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { continue; } pl_term *stream_val = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); pl_term **props = (pl_term **)pool_alloc(rt_ctrl, (ULO)(sizeof(*props) * 16), dbg_dat_ptr); ULO prop_n = 0; if (s->alias) { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "alias", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->alias); props[prop_n++] = p; } if (s->file_name) { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "file_name", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->file_name); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "file_no", 1); p->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)fileno(s->fp)); props[prop_n++] = p; } if (s->mode) { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "mode", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->mode); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "type", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->binary ? "binary" : "text"); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "line_count", 1); p->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(s->line_count ? s->line_count : 1)); props[prop_n++] = p; } { SLO pos = 0; if (id == 1 || id == 2) { pos = -1; } else if (id >= 4) { const long p = ftell(s->fp); pos = (p >= 0) ? (SLO)p : -1; if (pos >= 0 && s->readable && s->pushback_count) { pos -= (SLO)s->pushback_count; if (pos < 0) { pos = 0; } } } pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "position", 1); p->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, pos); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "reposition", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->repositionable ? "true" : "false"); props[prop_n++] = p; } { const CHR *eos = "not"; if (!s->readable) { eos = (id <= 2) ? "not" : "at"; } else if (s->pushback_count) { eos = "not"; } else if (s->eof_action == PL_EOF_ACTION_RESET) { eos = "not"; } else if (s->eos_past) { eos = "past"; } else if ((id >= 4) && stream_regular_file_at_end(s)) { eos = "at"; } else { eos = "not"; } pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "end_of_stream", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, eos); props[prop_n++] = p; } { const CHR *ea = "eof_code"; if (s->eof_action == PL_EOF_ACTION_ERROR) { ea = "error"; } else if (s->eof_action == PL_EOF_ACTION_RESET) { ea = "reset"; } pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "eof_action", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, ea); props[prop_n++] = p; } if (!s->binary) { { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "bom", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->bom ? "true" : "false"); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "encoding", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->encoding ? s->encoding : "UTF-8"); props[prop_n++] = p; } } if (s->readable) { props[prop_n++] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "input"); } if (s->writable) { props[prop_n++] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "output"); } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "newline", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "posix"); props[prop_n++] = p; } for (ULO pi = 0; pi < prop_n; pi++) { if (stop_at_first && *sol_count) { return cut_none(); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (stream_is_var && !unify_terms(goal->v.str.args[0], stream_val, env1, rt_ctrl, dbg_dat_ptr)) { continue; } if (!unify_terms(goal->v.str.args[1], props[pi], env1, rt_ctrl, dbg_dat_ptr)) { continue; } pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } return cut_none(); } if (!strcmp(fn, "open") && ((ar == 3) || (ar == 4))) { pl_term *file = deref_term(goal->v.str.args[0], env_in); pl_term *mode = deref_term(goal->v.str.args[1], env_in); if (!file || !mode) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, env_in, "open", 4); } if (mode->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (mode->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", mode, env_in, "open", 4); } streams_init(dbg_dat_ptr); bool binary_stream = false; // default: text_stream bool repositionable = true; unsigned char eof_action = PL_EOF_ACTION_EOF_CODE; bool bom_specified = false; bool use_bom = false; const CHR *alias_name = NULL; if (ar == 4) { pl_term *opts = deref_term(goal->v.str.args[3], env_in); if (!opts) { return cut_none(); } if (opts->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } if (!term_is_nil(opts) && !term_is_list_pair(opts)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", opts, env_in, "open", 4); } pl_term *cur = opts; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "args_not_sufficiently_instantiated"); } if (!term_is_list_pair(cur)) { // Trealla accepts improper option lists with a non-var tail (e.g. [type(binary)|foo]). break; } pl_term *opt = deref_term(cur->v.str.args[0], env_in); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "args_not_sufficiently_instantiated"); } if (opt->tag != PL_TERM_STRUCT || opt->v.str.arity != 1) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, env_in, "open", 4); } const CHR *opt_name = opt->v.str.functor; pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, env_in, "open", 4); } if (!strcmp(opt_name, "type")) { if (!strcmp(v->v.atom_name, "binary")) { binary_stream = true; } else if (!strcmp(v->v.atom_name, "text")) { binary_stream = false; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, env_in, "open", 4); } } else if (!strcmp(opt_name, "encoding")) { // Trealla validates but is effectively fixed at UTF-8 currently. } else if (!strcmp(opt_name, "alias")) { alias_name = v->v.atom_name; for (size_t i = 0; i < g_streams.cap; i++) { const pl_stream *s2 = &g_streams.items[i]; if (!s2->open || !s2->alias) { continue; } if (!strcmp(s2->alias, alias_name)) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "open", "source_sink", opt, env_in, "open", 4); } } } else if (!strcmp(opt_name, "reposition")) { if (!strcmp(v->v.atom_name, "true")) { repositionable = true; } else if (!strcmp(v->v.atom_name, "false")) { repositionable = false; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, env_in, "open", 4); } } else if (!strcmp(opt_name, "eof_action")) { if (!strcmp(v->v.atom_name, "error")) { eof_action = PL_EOF_ACTION_ERROR; } else if (!strcmp(v->v.atom_name, "eof_code")) { eof_action = PL_EOF_ACTION_EOF_CODE; } else if (!strcmp(v->v.atom_name, "reset")) { eof_action = PL_EOF_ACTION_RESET; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, env_in, "open", 4); } } else if (!strcmp(opt_name, "bom")) { bom_specified = true; if (!strcmp(v->v.atom_name, "true")) { use_bom = true; } else if (!strcmp(v->v.atom_name, "false")) { use_bom = false; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, env_in, "open", 4); } } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, env_in, "open", 4); } cur = deref_term(cur->v.str.args[1], env_in); if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "open", 4); } } } const char *fmode = NULL; bool readable = false; bool writable = false; if (!strcmp(mode->v.atom_name, "read")) { fmode = binary_stream ? "rb" : "r"; readable = true; } else if (!strcmp(mode->v.atom_name, "write")) { fmode = binary_stream ? "wb" : "w"; writable = true; } else if (!strcmp(mode->v.atom_name, "append")) { fmode = binary_stream ? "ab" : "a"; writable = true; } else if (!strcmp(mode->v.atom_name, "update")) { fmode = binary_stream ? "rb+" : "r+"; readable = true; writable = true; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "io_mode", mode, env_in, "open", 4); } errno = 0; FILE *fp = fopen(file->v.atom_name, fmode); if (!fp) { if ((errno == EACCES) || (errno == EPERM) || (!strcmp(mode->v.atom_name, "read") ? false : (errno == EROFS))) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "open", "source_sink", file, env_in, "open", 4); } return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, env_in, "open", 4); } if (writable && !binary_stream) { (void)setvbuf(fp, NULL, _IOLBF, 0); } const SLO id = stream_alloc_id(dbg_dat_ptr); if (id < 0) { (void)fclose(fp); return cut_none(); } g_streams.items[id] = (pl_stream){.open = true, .readable = readable, .writable = writable, .binary = binary_stream, .repositionable = repositionable, .eof_action = eof_action, .bom = false, .encoding = binary_stream ? NULL : strdup("UTF-8"), .fp = fp, .alias = alias_name ? strdup(alias_name) : NULL, .file_name = strdup(file->v.atom_name ? file->v.atom_name : ""), .line_count = 1, .line_pos = 1, .mode = strdup(mode->v.atom_name ? mode->v.atom_name : "")}; if (!binary_stream) { bool is_regular = false; { struct stat st; const int fd = fileno(fp); if (fd >= 0 && (fstat(fd, &st) == 0) && S_ISREG(st.st_mode)) { is_regular = true; } } if (!is_regular && !bom_specified) { bom_specified = true; use_bom = false; } pl_stream *s = &g_streams.items[id]; if (readable && (!bom_specified || use_bom)) { const int b0 = fgetc(fp); const int b1 = fgetc(fp); const int b2 = fgetc(fp); if (b0 == 0xEF && b1 == 0xBB && b2 == 0xBF) { s->bom = true; } else { if (b2 != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)b2); } if (b1 != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)b1); } if (b0 != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)b0); } } if (feof(fp)) { clearerr(fp); } } else if (!strcmp(mode->v.atom_name, "write") && use_bom) { const unsigned char bom_bytes[3] = {0xEF, 0xBB, 0xBF}; (void)fwrite(bom_bytes, 1, sizeof(bom_bytes), fp); s->bom = true; } } pl_term *st = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal->v.str.args[2], st, env1, rt_ctrl, dbg_dat_ptr)) { (void)fclose(fp); stream_free_pushback(&g_streams.items[id]); stream_free_meta(&g_streams.items[id]); g_streams.items[id] = (pl_stream){0}; return cut_none(); } return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "close") && ((ar == 1) || (ar == 2))) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "close", ar); } if (ar == 2) { pl_term *opts = deref_term(goal->v.str.args[1], env_in); if (!opts) { return cut_none(); } if (opts->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } pl_term *cur = opts; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "close_option"); } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", cur, env_in, "close", 2); } pl_term *opt = deref_term(cur->v.str.args[0], env_in); if (!opt) { return cut_none(); } if (opt->tag != PL_TERM_STRUCT || opt->v.str.arity != 1 || strcmp(opt->v.str.functor, "force")) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "close_option", opt, env_in, "close", 2); } pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { return cut_none(); } if (v->tag != PL_TERM_ATOM || strcmp(v->v.atom_name, "true")) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "close_option", opt, env_in, "close", 2); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "close", 2); } } } streams_init(dbg_dat_ptr); if (id >= 0 && id <= 2) { return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "close", ar); } if (s->fp) { (void)fclose(s->fp); } stream_free_pushback(s); stream_free_meta(s); g_streams.items[id] = (pl_stream){0}; if (g_streams.current_input == id) { g_streams.current_input = 0; } if (g_streams.current_output == id) { g_streams.current_output = 1; } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "get_code") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "get_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "get_code", 2); } return cut_none(); } pl_term *code_term = deref_term(code_arg, env_in); if (!code_term) { return cut_none(); } if (code_term->tag != PL_TERM_VAR && code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, env_in, "get_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "get_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "get_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "get_code", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (code == -1); pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, code); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(code_arg, it, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "peek_code") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "peek_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "peek_code", 2); } return cut_none(); } pl_term *code_term = deref_term(code_arg, env_in); if (!code_term) { return cut_none(); } if (code_term->tag != PL_TERM_VAR && code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, env_in, "peek_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "peek_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "peek_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "peek_code", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); } } pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, code); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(code_arg, it, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "put_code") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "put_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "put_code", 2); } return cut_none(); } pl_term *code_term = deref_term(code_arg, env_in); if (!code_term) { return cut_none(); } if (code_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, env_in, "put_code", ar); } const SLO code = code_term->v.int_value; if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "put_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "put_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "put_code", ar); } if (code < 0 || code > 255) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "put_code", ar); } stream_write_char(s, id, (char)(unsigned char)code); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "unget_code") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "unget_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "unget_code", 2); } return cut_none(); } pl_term *code_term = deref_term(code_arg, env_in); if (!code_term) { return cut_none(); } if (code_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, env_in, "unget_code", ar); } const SLO code = code_term->v.int_value; if (code < -1) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character_code", "unget_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "unget_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "unget_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "unget_code", ar); } stream_pushback_push(s, dbg_dat_ptr, code); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "get_char") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "get_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "get_char", 2); } return cut_none(); } pl_term *ch_term = deref_term(char_arg, env_in); if (!ch_term) { return cut_none(); } if (ch_term->tag != PL_TERM_VAR && ch_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, env_in, "get_char", ar); } if (ch_term->tag == PL_TERM_ATOM) { if (strcmp(ch_term->v.atom_name, "end_of_file") && (strlen(ch_term->v.atom_name) != 1)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, env_in, "get_char", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "get_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "get_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "get_char", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (code == -1); pl_term *out_ch = NULL; if (code == -1) { out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { CHR tmp[2] = {(CHR)(unsigned char)code, '\0'}; out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, tmp); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(char_arg, out_ch, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "peek_char") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "peek_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "peek_char", 2); } return cut_none(); } pl_term *ch_term = deref_term(char_arg, env_in); if (!ch_term) { return cut_none(); } if (ch_term->tag != PL_TERM_VAR && ch_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, env_in, "peek_char", ar); } if (ch_term->tag == PL_TERM_ATOM) { if (strcmp(ch_term->v.atom_name, "end_of_file") && (strlen(ch_term->v.atom_name) != 1)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, env_in, "peek_char", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "peek_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "peek_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "peek_char", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); } } pl_term *out_ch = NULL; if (code == -1) { out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { CHR tmp[2] = {(CHR)(unsigned char)code, '\0'}; out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, tmp); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(char_arg, out_ch, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "put_char") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "put_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "put_char", 2); } return cut_none(); } pl_term *ch_term = deref_term(char_arg, env_in); if (!ch_term) { return cut_none(); } if (ch_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character"); } if (ch_term->tag != PL_TERM_ATOM || (strlen(ch_term->v.atom_name) != 1)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch_term, env_in, "put_char", ar); } if (!s->writable) { if (ar == 2) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "put_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "put_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "put_char", ar); } stream_write_char(s, id, (char)(unsigned char)ch_term->v.atom_name[0]); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "write") && ((ar == 1) || (ar == 2))) { return solve_goals_builtin_write( prog, goal, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "writeq") && ((ar == 1) || (ar == 2))) { return solve_goals_builtin_writeq( prog, goal, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "write_canonical") && ((ar == 1) || (ar == 2))) { return solve_goals_builtin_write_canonical( prog, goal, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "write_term") && ((ar == 2) || (ar == 3))) { return solve_goals_builtin_write_term( prog, goal, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "read") && ((ar == 1) || (ar == 2))) { return solve_goals_builtin_read( prog, goal, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "read_term") && ((ar == 2) || (ar == 3))) { return solve_goals_builtin_read_term( prog, goal, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "file_to_chars") && (ar == 2)) { pl_term *file = deref_term(goal->v.str.args[0], env_in); if (!file) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, env_in, "file_to_chars", 2); } pl_term *chars = NULL; int io_errno = 0; const flowlog_file_chars_status st = flowlog_file_to_chars_term( file->v.atom_name, rt_ctrl, dbg_dat_ptr, &chars, &io_errno); if (st != FLOWLOG_FILE_CHARS_OK) { if (st == FLOWLOG_FILE_CHARS_ERR_INVALID) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "file_to_chars", 2); } if (st == FLOWLOG_FILE_CHARS_ERR_TOO_LARGE) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "file_to_chars", 2); } if (io_errno == EACCES || io_errno == EPERM) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "open", "source_sink", file, env_in, "file_to_chars", 2); } if (st == FLOWLOG_FILE_CHARS_ERR_OPEN) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, env_in, "file_to_chars", 2); } return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "source_sink", file, env_in, "file_to_chars", 2); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], chars, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if ((!strcmp(fn, "file_to_bytes") || !strcmp(fn, "file_to_byte")) && (ar == 2)) { pl_term *file = deref_term(goal->v.str.args[0], env_in); if (!file) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, env_in, fn, 2); } pl_term *bytes = NULL; int io_errno = 0; const flowlog_file_bytes_status st = flowlog_file_to_bytes_term( file->v.atom_name, rt_ctrl, dbg_dat_ptr, &bytes, &io_errno); if (st != FLOWLOG_FILE_BYTES_OK) { if (st == FLOWLOG_FILE_BYTES_ERR_TOO_LARGE) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } if (io_errno == EACCES || io_errno == EPERM) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "open", "source_sink", file, env_in, fn, 2); } if (st == FLOWLOG_FILE_BYTES_ERR_OPEN) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, env_in, fn, 2); } return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "source_sink", file, env_in, fn, 2); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], bytes, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "unget_char") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "unget_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "unget_char", 2); } return cut_none(); } pl_term *ch_term = deref_term(char_arg, env_in); if (!ch_term) { return cut_none(); } if (ch_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character"); } if (ch_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, env_in, "unget_char", ar); } SLO code = -1; if (!strcmp(ch_term->v.atom_name, "end_of_file")) { code = -1; } else { if (strlen(ch_term->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, env_in, "unget_char", ar); } code = (SLO)(unsigned char)ch_term->v.atom_name[0]; } if (!s->readable) { if (ar == 2) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "unget_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "unget_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "unget_char", ar); } stream_pushback_push(s, dbg_dat_ptr, code); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "get_byte") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "get_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "get_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term(byte_arg, env_in); if (!byte_term) { return cut_none(); } if (byte_term->tag != PL_TERM_VAR && byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, env_in, "get_byte", ar); } if (byte_term->tag == PL_TERM_INT) { const SLO v = byte_term->v.int_value; if (v < -1 || v > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, env_in, "get_byte", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "get_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "get_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "text_stream", sid, env_in, "get_byte", ar); } SLO byte = -1; if (s->pushback_count) { byte = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); byte = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (byte == -1); pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, byte); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(byte_arg, it, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "peek_byte") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "peek_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "peek_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term(byte_arg, env_in); if (!byte_term) { return cut_none(); } if (byte_term->tag != PL_TERM_VAR && byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, env_in, "peek_byte", ar); } if (byte_term->tag == PL_TERM_INT) { const SLO v = byte_term->v.int_value; if (v < -1 || v > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, env_in, "peek_byte", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "peek_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "peek_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "text_stream", sid, env_in, "peek_byte", ar); } SLO byte = -1; if (s->pushback_count) { byte = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); byte = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); } } pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, byte); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(byte_arg, it, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "put_byte") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "put_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "put_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term(byte_arg, env_in); if (!byte_term) { return cut_none(); } if (byte_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "byte"); } if (byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "byte", byte_term, env_in, "put_byte", ar); } const SLO byte = byte_term->v.int_value; if (byte < 0 || byte > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "byte", byte_term, env_in, "put_byte", ar); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "put_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "put_byte", 1); } if (!s->binary) { if (ar == 2) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "text_stream", st_term, env_in, "put_byte", 2); } pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "text_stream", sid, env_in, "put_byte", 1); } (void)fputc((unsigned char)byte, s->fp); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "unget_byte") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "unget_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "unget_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term(byte_arg, env_in); if (!byte_term) { return cut_none(); } if (byte_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte"); } if (byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, env_in, "unget_byte", ar); } const SLO byte = byte_term->v.int_value; if (byte < -1 || byte > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, env_in, "unget_byte", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "unget_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "unget_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "text_stream", sid, env_in, "unget_byte", ar); } stream_pushback_push(s, dbg_dat_ptr, byte); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "nl") && (ar == 1)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "nl", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "nl", 1); } if (!s->writable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "nl", 1); } stream_write_char(s, id, '\n'); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flush_output") && (ar == 1)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "flush_output", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "flush_output", 1); } if (!s->writable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "flush_output", 1); } if (flowlog_capture_user_output_stream(id)) { stream_drain_user_output_capture_if_enabled(s, id, rt_ctrl, dbg_dat_ptr); } else { (void)fflush(s->fp); } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "at_end_of_stream") && (ar == 1)) { pl_term *st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "at_end_of_stream", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "at_end_of_stream", 1); } if (!s->readable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "at_end_of_stream", 1); } if (s->pushback_count) { return cut_none(); } const int c = fgetc(s->fp); if (c == EOF) { return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); return cut_none(); } if (!strcmp(fn, "tab") && ((ar == 1) || (ar == 2))) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *n_term = deref_term(goal->v.str.args[0], env_in); if (ar == 2) { if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return cut_none(); } n_term = deref_term(goal->v.str.args[1], env_in); } if (!n_term || n_term->tag != PL_TERM_INT) { return cut_none(); } const SLO n = n_term->v.int_value; if (n < 0 || n > 65535) { return cut_none(); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr) || !s->writable) { return cut_none(); } for (SLO i = 0; i < n; i++) { stream_write_char(s, id, ' '); } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } // All-solutions predicates (ISO). if (!strcmp(fn, "findall") && (ar == 3)) { pl_term *templ_in = goal->v.str.args[0]; pl_term *sub_goal = deref_term(goal->v.str.args[1], env_in); pl_env *env_out = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_env *call_env = (pl_env *)pool_alloc(rt_ctrl, sizeof(*call_env), dbg_dat_ptr); *call_env = (pl_env){0}; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m0; copy_var_map_init(&m0, scope); pl_term *templ_local = copy_term_tr(templ_in, env_in, call_env, &m0, rt_ctrl, dbg_dat_ptr, 0); pl_term *goal_local = NULL; if (sub_goal) { goal_local = copy_term_tr(sub_goal, env_in, call_env, &m0, rt_ctrl, dbg_dat_ptr, 0); } copy_var_map_free(&m0); const bool templ_ground = term_is_syntactic_ground(templ_local, 0); pl_term *list = NULL; if (templ_ground) { if (goal_local) { pl_term *sub_goals[1] = {goal_local}; ULO inner_sol = 0; int local_barrier = 0; pl_cut_signal r = solve_goals_cb(prog, q, sub_goals, 1, call_env, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, NULL, NULL, rt_ctrl, dbg_dat_ptr); if (r.except) { return r; } list = build_repeat_list_rt(rt_ctrl, dbg_dat_ptr, templ_local, inner_sol); } else { list = make_nil_rt(dbg_dat_ptr); } } else { pl_findall_ctx *ctx = (pl_findall_ctx *)pool_alloc(rt_ctrl, sizeof(*ctx), dbg_dat_ptr); *ctx = (pl_findall_ctx){.template = templ_local, .env_out = env_out, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr}; term_vec_init(&ctx->results); if (goal_local) { pl_term *sub_goals[1] = {goal_local}; ULO inner_sol = 0; int local_barrier = 0; const bool saved_safe = g_on_solution_safe_temp_release; g_on_solution_safe_temp_release = true; pl_cut_signal r = solve_goals_cb(prog, q, sub_goals, 1, call_env, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, findall_on_solution, ctx, rt_ctrl, dbg_dat_ptr); g_on_solution_safe_temp_release = saved_safe; if (r.except) { if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx->alloc, dbg_dat_ptr); } else { temp_alloc_free_all(&ctx->alloc, rt_ctrl, dbg_dat_ptr); } term_vec_free(&ctx->results); return r; } } if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx->alloc, dbg_dat_ptr); } list = build_list_rt(rt_ctrl, dbg_dat_ptr, ctx->results.items, ctx->results.count); term_vec_free(&ctx->results); } if (unify_terms(goal->v.str.args[2], list, env_out, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_out, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if ((!strcmp(fn, "bagof") || !strcmp(fn, "setof")) && (ar == 3)) { const bool is_setof = !strcmp(fn, "setof"); pl_var_list exist = {0}; var_list_init(&exist); pl_term *goal_core = strip_bagof_existentials(goal->v.str.args[1], env_in, &exist, dbg_dat_ptr); pl_var_stack st; pl_var_list goal_vars = {0}; pl_var_list templ_vars = {0}; var_stack_init(&st); var_list_init(&goal_vars); term_collect_vars_tr(goal_core, env_in, &st, &goal_vars, dbg_dat_ptr, 0); var_stack_free(&st); var_stack_init(&st); var_list_init(&templ_vars); term_collect_vars_tr(goal->v.str.args[0], env_in, &st, &templ_vars, dbg_dat_ptr, 0); var_stack_free(&st); pl_term **free_vars = NULL; ULO free_count = 0; if (goal_vars.count) { free_vars = (pl_term **)malloc(sizeof(pl_term *) * goal_vars.count); if (!free_vars) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } } for (ULO i = 0; i < goal_vars.count; i++) { pl_var_key k = goal_vars.items[i].key; if (var_list_contains_key(&templ_vars, k) || var_list_contains_key(&exist, k)) { continue; } free_vars[free_count++] = goal_vars.items[i].term; } pl_term *outer_key = build_list_rt(rt_ctrl, dbg_dat_ptr, free_vars, free_count); pl_env *call_env = (pl_env *)pool_alloc(rt_ctrl, sizeof(*call_env), dbg_dat_ptr); *call_env = (pl_env){0}; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m0; copy_var_map_init(&m0, scope); pl_term *templ_local = copy_term_tr(goal->v.str.args[0], env_in, call_env, &m0, rt_ctrl, dbg_dat_ptr, 0); pl_term *goal_local = copy_term_tr(goal_core, env_in, call_env, &m0, rt_ctrl, dbg_dat_ptr, 0); pl_term **local_free = NULL; if (free_count) { local_free = (pl_term **)malloc(sizeof(pl_term *) * free_count); if (!local_free) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } } for (ULO i = 0; i < free_count; i++) { local_free[i] = copy_term_tr(free_vars[i], env_in, call_env, &m0, rt_ctrl, dbg_dat_ptr, 0); } pl_term *key_local = build_list_rt(rt_ctrl, dbg_dat_ptr, local_free, free_count); copy_var_map_free(&m0); pl_env *env_base = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_bagof_ctx *ctx = (pl_bagof_ctx *)pool_alloc(rt_ctrl, sizeof(*ctx), dbg_dat_ptr); *ctx = (pl_bagof_ctx){ .key = key_local, .template = templ_local, .env_out = env_base, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, }; group_vec_init(&ctx->groups); pl_cut_signal result = cut_none(); if (goal_local) { pl_term *sub_goals[1] = {goal_local}; ULO inner_sol = 0; int local_barrier = 0; const bool saved_safe = g_on_solution_safe_temp_release; g_on_solution_safe_temp_release = true; pl_cut_signal r = solve_goals_cb(prog, q, sub_goals, 1, call_env, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, bagof_on_solution, ctx, rt_ctrl, dbg_dat_ptr); g_on_solution_safe_temp_release = saved_safe; if (r.except) { if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx->alloc, dbg_dat_ptr); } else { temp_alloc_free_all(&ctx->alloc, rt_ctrl, dbg_dat_ptr); } result = r; goto bagof_cleanup; } } if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx->alloc, dbg_dat_ptr); } if (!ctx->groups.count) { goto bagof_cleanup; } if (ctx->groups.count > 1) { g_group_qsort_env = env_base; g_group_qsort_dbg_dat_ptr = dbg_dat_ptr; qsort(ctx->groups.items, (size_t)ctx->groups.count, sizeof(pl_solution_group), qsort_solution_group_cmp); g_group_qsort_env = NULL; g_group_qsort_dbg_dat_ptr = NULL; } if (is_setof) { for (ULO gi = 0; gi < ctx->groups.count; gi++) { pl_solution_group *g = &ctx->groups.items[gi]; if (g->templates.count) { g_qsort_env = env_base; g_qsort_dbg_dat_ptr = dbg_dat_ptr; qsort(g->templates.items, (size_t)g->templates.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp); g_qsort_env = NULL; g_qsort_dbg_dat_ptr = NULL; } ULO uniq = 0; for (ULO i = 0; i < g->templates.count; i++) { if (!uniq || (compare_std_terms_env(g->templates.items[i], g->templates.items[uniq - 1], env_base, dbg_dat_ptr) != 0)) { g->templates.items[uniq++] = g->templates.items[i]; } } g->templates.count = uniq; } } for (ULO gi = 0; gi < ctx->groups.count; gi++) { if (stop_at_first && *sol_count) { goto bagof_cleanup; } pl_solution_group *g = &ctx->groups.items[gi]; pl_term *bag_list = build_list_rt(rt_ctrl, dbg_dat_ptr, g->templates.items, g->templates.count); pl_env *env1 = env_clone(env_base, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[2], bag_list, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(outer_key, g->key, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { result = r; goto bagof_cleanup; } } } bagof_cleanup: group_vec_free(&ctx->groups); free(local_free); free(free_vars); var_list_free(&templ_vars); var_list_free(&goal_vars); var_list_free(&exist); return result; } if (!strcmp(fn, "flowlog_cpuproc_id") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const SLO id = (SLO)get_id_cpuproc_fast(rt_ctrl); pl_term *id_term = make_int_rt(rt_ctrl, dbg_dat_ptr, id); if (!unify_terms(goal->v.str.args[0], id_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_in_cpuproc") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *t_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, am_I_in_the_CPUPROC_module() ? "true" : "false"); if (!unify_terms(goal->v.str.args[0], t_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_last_tc_cp_mask") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *m_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_cp_mask); if (!unify_terms(goal->v.str.args[0], m_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_last_tc_cp_count") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const unsigned long long m = (unsigned long long)g_last_tc_cp_mask; const SLO n = (SLO)__builtin_popcountll(m); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, n); if (!unify_terms(goal->v.str.args[0], n_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_last_tc_worker_count") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_worker_count); if (!unify_terms(goal->v.str.args[0], n_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_last_tc_start_ok") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_start_ok); if (!unify_terms(goal->v.str.args[0], n_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_last_tc_start_error_code") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_start_err_code); if (!unify_terms(goal->v.str.args[0], n_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_last_tc_start_error_text") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *t_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, g_last_tc_start_err_text); if (!unify_terms(goal->v.str.args[0], t_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_n_cpuproc") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const SLO n = (SLO)get_n_cpuproc(); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, n); if (!unify_terms(goal->v.str.args[0], n_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_taskjob_id") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const SLO id = (SLO)get_id_taskjob_fast(rt_ctrl); pl_term *id_term = make_int_rt(rt_ctrl, dbg_dat_ptr, id); if (!unify_terms(goal->v.str.args[0], id_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_n_taskjob") && (ar == 1)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const SLO n = (SLO)get_n_taskjob(); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, n); if (!unify_terms(goal->v.str.args[0], n_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_db_epochs") && (ar == 2)) { if (!prog) { return cut_none(); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const unsigned long clause_epoch = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long index_epoch = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); pl_term *cl_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)clause_epoch); pl_term *ix_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)index_epoch); if (!unify_terms(goal->v.str.args[0], cl_term, env1, rt_ctrl, dbg_dat_ptr) || !unify_terms(goal->v.str.args[1], ix_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_and_safe") && (ar == 2)) { if (!prog) { return cut_none(); } pl_term *pi = deref_term(goal->v.str.args[0], env_in); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, env_in, "flowlog_and_safe", 2); } pl_term *name = deref_term(pi->v.str.args[0], env_in); pl_term *arity_term = deref_term(pi->v.str.args[1], env_in); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } if (name->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name, env_in, "flowlog_and_safe", 2); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, env_in, "flowlog_and_safe", 2); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, env_in, "flowlog_and_safe", 2); } prog_par_and_safety_ensure(prog, rt_ctrl, dbg_dat_ptr); bool safe = false; if (prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, name->v.atom_name, (ULO)arity_val); safe = e && e->and_safe; } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *safe_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, safe ? "true" : "false"); if (!unify_terms(goal->v.str.args[1], safe_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "flowlog_and_safe_goal") && (ar == 2)) { if (!prog) { return cut_none(); } pl_term *g0 = deref_term(goal->v.str.args[0], env_in); if (!g0) { return cut_none(); } if (g0->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (g0->tag != PL_TERM_ATOM && g0->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", g0, env_in, "flowlog_and_safe_goal", 2); } const bool safe = par_and_goal_is_safe_test(prog, g0, env_in, rt_ctrl, dbg_dat_ptr); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *safe_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, safe ? "true" : "false"); if (!unify_terms(goal->v.str.args[1], safe_term, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals( prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "countall") && (ar == 2)) { pl_term *sub_goal_in = deref_term(goal->v.str.args[0], env_in); if (!sub_goal_in) { return cut_none(); } pl_term *count_arg = deref_term(goal->v.str.args[1], env_in); if (!count_arg) { return cut_none(); } if (count_arg->tag != PL_TERM_VAR && count_arg->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", count_arg, env_in, "countall", 2); } pl_env *call_env = (pl_env *)pool_alloc(rt_ctrl, sizeof(*call_env), dbg_dat_ptr); *call_env = (pl_env){0}; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m0; copy_var_map_init(&m0, scope); pl_term *goal_local = copy_term_tr(sub_goal_in, env_in, call_env, &m0, rt_ctrl, dbg_dat_ptr, 0); copy_var_map_free(&m0); if (!goal_local) { return cut_none(); } pl_term *call_goal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "call", 1); call_goal->v.str.args[0] = goal_local; pl_term *sub_goals[1] = {call_goal}; ULO inner_sol = 0; int local_barrier = 0; pl_cut_signal inner = solve_goals_cb(prog, q, sub_goals, 1, call_env, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, NULL, NULL, rt_ctrl, dbg_dat_ptr); if (inner.except) { return inner; } if (inner.cut && (inner.target != &local_barrier)) { return inner; } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *n = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)inner_sol); if (!unify_terms(goal->v.str.args[1], n, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "listing") && (ar == 1)) { pl_term *spec0 = deref_term(goal->v.str.args[0], env_in); if (!spec0) { return cut_none(); } if (spec0->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "listing", 1); } pl_term *spec = spec0; if (spec->tag == PL_TERM_STRUCT && spec->v.str.arity == 2 && !strcmp(spec->v.str.functor, ":")) { spec = deref_term(spec->v.str.args[1], env_in); if (!spec) { return cut_none(); } } const CHR *want_name = NULL; bool any_arity = false; ULO want_arity = 0; if (spec->tag == PL_TERM_ATOM) { want_name = spec->v.atom_name; any_arity = true; } else if (spec->tag == PL_TERM_STRUCT && spec->v.str.arity == 2 && !strcmp(spec->v.str.functor, "/")) { pl_term *name_term = deref_term(spec->v.str.args[0], env_in); pl_term *arity_term = deref_term(spec->v.str.args[1], env_in); if (!name_term || !arity_term) { return cut_none(); } if (name_term->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "listing", 1); } if (name_term->tag != PL_TERM_ATOM || arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", spec, env_in, "listing", 1); } if (arity_term->v.int_value < 0 || arity_term->v.int_value > 1024) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", spec, env_in, "listing", 1); } want_name = name_term->v.atom_name; want_arity = (ULO)arity_term->v.int_value; any_arity = false; } else if (spec->tag == PL_TERM_STRUCT) { want_name = spec->v.str.functor; want_arity = spec->v.str.arity; any_arity = false; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", spec, env_in, "listing", 1); } streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return cut_none(); } if (!s->writable) { pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "listing", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "listing", 1); } const pl_clause **snap = NULL; ULO snap_count = 0; if (prog && prog->clauses && prog->clause_count) { prog_db_rlock(prog); snap = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(*snap) * prog->clause_count, dbg_dat_ptr); for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *hn = NULL; ULO ha = 0; if (h->tag == PL_TERM_ATOM) { hn = h->v.atom_name; ha = 0; } else if (h->tag == PL_TERM_STRUCT) { hn = h->v.str.functor; ha = h->v.str.arity; } else { continue; } if (!hn || strcmp(hn, want_name) || (!any_arity && (ha != want_arity))) { continue; } snap[snap_count++] = cl; } prog_db_runlock(prog); } for (ULO i = 0; i < snap_count; i++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = snap[i]; if (!cl || !cl->head) { continue; } pl_temp_mark m = {0}; const bool release_temp = (g_temp_alloc != NULL); if (release_temp) { m = temp_alloc_mark(g_temp_alloc); } pl_term *t = cl->head; if (cl->body_count && cl->body) { pl_term **body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = cl->body[bi + 1]; } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); pl_term *rule = make_struct_rt(rt_ctrl, dbg_dat_ptr, ":-", 2); rule->v.str.args[0] = cl->head; rule->v.str.args[1] = body_term; t = rule; } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, t, cl->env, &wopts, &sb, dbg_dat_ptr); sbuf_append_char(&sb, '.'); sbuf_append_char(&sb, '\n'); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); if (release_temp) { temp_alloc_release(g_temp_alloc, m, rt_ctrl, dbg_dat_ptr); } } if (id != 1) { (void)fflush(s->fp); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } // Dynamic database predicates (ISO core). if ((!strcmp(fn, "asserta") || !strcmp(fn, "assertz") || !strcmp(fn, "assert")) && (ar == 1)) { pl_term *clause_in = deref_term(goal->v.str.args[0], env_in); if (!clause_in) { return cut_none(); } if (clause_in->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 1); } pl_term *head_in = clause_in; pl_term *body_in = NULL; if (clause_in->tag == PL_TERM_STRUCT && clause_in->v.str.arity == 2 && !strcmp(clause_in->v.str.functor, ":-")) { head_in = deref_term(clause_in->v.str.args[0], env_in); body_in = deref_term(clause_in->v.str.args[1], env_in); } if (!head_in) { return cut_none(); } if (head_in->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 1); } if (head_in->tag != PL_TERM_ATOM && head_in->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", head_in, env_in, fn, 1); } const CHR *target_name = (head_in->tag == PL_TERM_ATOM) ? head_in->v.atom_name : head_in->v.str.functor; const ULO target_arity = (head_in->tag == PL_TERM_ATOM) ? 0 : head_in->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, env_in, fn, 1); } bool dyn = false; const bool defined = prog_pred_defined(prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, env_in, fn, 1); } pl_term **body0 = NULL; ULO body_count = 0; ULO body_cap = 0; if (body_in && !term_is_true_atom(body_in, env_in)) { pl_parse tmp = {0}; tmp.rt_ctrl = rt_ctrl; tmp.dbg_dat_ptr = dbg_dat_ptr; flatten_conjunction_goals(&tmp, body_in, &body0, &body_count, &body_cap); if (body_count == 1 && term_is_true_atom(body0[0], env_in)) { body_count = 0; } } for (ULO i = 0; i < body_count; i++) { pl_term *bad = find_noncallable_goal_env(body0[i], env_in, 0); if (bad) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", bad, env_in, fn, 1); } } // Dynamic database updates are permanent side-effects: allocate their clause/term structures outside of the query // temporary allocator so they survive backtracking and long-running loops (e.g. ISO test harness). pl_temp_alloc *saved_tmp = temp_alloc_suspend(); pl_clause *cl = (pl_clause *)pool_alloc(rt_ctrl, sizeof(*cl), dbg_dat_ptr); memset(cl, 0, sizeof(*cl)); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); cl->scope = scope; pl_env *cl_env = (pl_env *)pool_alloc(rt_ctrl, sizeof(*cl_env), dbg_dat_ptr); memset(cl_env, 0, sizeof(*cl_env)); cl->env = cl_env; pl_copy_var_map m; copy_var_map_init(&m, scope); cl->head = copy_term_tr(head_in, env_in, cl_env, &m, rt_ctrl, dbg_dat_ptr, 0); cl->body_count = body_count; if (body_count) { cl->body = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * (body_count + 1), dbg_dat_ptr); cl->body[0] = NULL; for (ULO i = 0; i < body_count; i++) { cl->body[i + 1] = copy_term_tr(body0[i], env_in, cl_env, &m, rt_ctrl, dbg_dat_ptr, 0); } } else { cl->body = NULL; } cl->var_count = m.next_var_id; copy_var_map_free(&m); clause_compute_tpl_sizes(cl); if (prog && cl->head) { const CHR *pred_name = NULL; ULO pred_arity = 0; if (cl->head->tag == PL_TERM_ATOM) { pred_name = cl->head->v.atom_name; pred_arity = 0; } else if (cl->head->tag == PL_TERM_STRUCT) { pred_name = cl->head->v.str.functor; pred_arity = cl->head->v.str.arity; } if (pred_name) { prog_dyn_pred_add(prog, pred_name, pred_arity, rt_ctrl, dbg_dat_ptr); } } const bool at_front = !strcmp(fn, "asserta"); prog_insert_clause(prog, cl, at_front, rt_ctrl, dbg_dat_ptr); temp_alloc_resume(saved_tmp); return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "retract") && (ar == 1)) { pl_term *pat = deref_term(goal->v.str.args[0], env_in); if (!pat) { return cut_none(); } if (pat->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retract", 1); } pl_term *pat_head = pat; pl_term *pat_body = NULL; const bool pat_is_rule = pat->tag == PL_TERM_STRUCT && pat->v.str.arity == 2 && !strcmp(pat->v.str.functor, ":-"); if (pat_is_rule) { pat_head = deref_term(pat->v.str.args[0], env_in); pat_body = deref_term(pat->v.str.args[1], env_in); } if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retract", 1); } if (pat_head->tag != PL_TERM_ATOM && pat_head->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", pat_head, env_in, "retract", 1); } const CHR *target_name = (pat_head->tag == PL_TERM_ATOM) ? pat_head->v.atom_name : pat_head->v.str.functor; const ULO target_arity = (pat_head->tag == PL_TERM_ATOM) ? 0 : pat_head->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, env_in, "retract", 1); } bool dyn = false; const bool defined = prog_pred_defined(prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, env_in, "retract", 1); } if (!defined) { return cut_none(); // undefined predicate: just fail } if (!prog || !prog->clause_count || !prog->clauses) { return cut_none(); } for (ULO i = 1; i <= prog->clause_count; i++) { pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, target_name) || (h_arity != target_arity)) { continue; } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term *head = clone_term_with_scope(cl->head, cl->scope, scope, rt_ctrl, dbg_dat_ptr); pl_term **body_goals = NULL; if (cl->body_count) { body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = clone_term_with_scope(cl->body[bi + 1], cl->scope, scope, rt_ctrl, dbg_dat_ptr); } } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); body_term = wrap_var_goals_rt(body_term, rt_ctrl, dbg_dat_ptr, 0); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); env_apply_clause_bindings(cl, scope, env1, rt_ctrl, dbg_dat_ptr); bool ok = false; if (pat_is_rule) { ok = unify_terms(pat_head, head, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(pat_body, body_term, env1, rt_ctrl, dbg_dat_ptr); } else { if (!term_is_true_atom(body_term, env1)) { continue; } ok = unify_terms(pat_head, head, env1, rt_ctrl, dbg_dat_ptr); } if (!ok) { continue; } // Permanent side-effect: once a clause is retracted, it stays retracted even if we backtrack. prog_db_wlock(prog); prog->clauses[i] = NULL; prog_index_invalidate(prog); prog_db_wunlock(prog); pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "retractall") && (ar == 1)) { pl_term *pat_head = deref_term(goal->v.str.args[0], env_in); if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retractall", 1); } if (pat_head->tag == PL_TERM_STRUCT && pat_head->v.str.arity == 2 && !strcmp(pat_head->v.str.functor, ":-")) { pat_head = deref_term(pat_head->v.str.args[0], env_in); } if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retractall", 1); } if (pat_head->tag != PL_TERM_ATOM && pat_head->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", pat_head, env_in, "retractall", 1); } const CHR *target_name = (pat_head->tag == PL_TERM_ATOM) ? pat_head->v.atom_name : pat_head->v.str.functor; const ULO target_arity = (pat_head->tag == PL_TERM_ATOM) ? 0 : pat_head->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, env_in, "retractall", 1); } bool dyn = false; const bool defined = prog_pred_defined(prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, env_in, "retractall", 1); } bool changed = false; if (defined && prog && prog->clauses && prog->clause_count) { for (ULO i = 1; i <= prog->clause_count; i++) { pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, target_name) || (h_arity != target_arity)) { continue; } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term *head = clone_term_with_scope(cl->head, cl->scope, scope, rt_ctrl, dbg_dat_ptr); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); env_apply_clause_bindings(cl, scope, env1, rt_ctrl, dbg_dat_ptr); if (unify_terms(pat_head, head, env1, rt_ctrl, dbg_dat_ptr)) { prog_db_wlock(prog); prog->clauses[i] = NULL; prog_db_wunlock(prog); changed = true; } } } if (changed) { prog_index_invalidate(prog); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "abolish") && (ar == 1)) { pl_term *pi = deref_term(goal->v.str.args[0], env_in); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, env_in, "abolish", 1); } pl_term *name = deref_term(pi->v.str.args[0], env_in); pl_term *arity_term = deref_term(pi->v.str.args[1], env_in); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } if (name->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name, env_in, "abolish", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, env_in, "abolish", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, env_in, "abolish", 1); } const SLO max_arity = 255; // current_prolog_flag(max_arity, 255) if (arity_val > max_arity) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "abolish", 1); } bool dyn = false; const bool builtin = builtin_pred_defined(name->v.atom_name, (ULO)arity_val); const bool defined = prog_pred_defined(prog, name->v.atom_name, (ULO)arity_val, &dyn); if (builtin || (defined && !dyn)) { return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, env_in, "abolish", 1); } bool changed = false; if (prog && prog->clauses && prog->clause_count) { for (ULO i = 1; i <= prog->clause_count; i++) { pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *fn_name = NULL; ULO fn_arity = 0; if (h->tag == PL_TERM_ATOM) { fn_name = h->v.atom_name; fn_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { fn_name = h->v.str.functor; fn_arity = h->v.str.arity; } else { continue; } if (!strcmp(fn_name, name->v.atom_name) && (fn_arity == (ULO)arity_val)) { prog_db_wlock(prog); prog->clauses[i] = NULL; prog_db_wunlock(prog); changed = true; } } } if (changed) { prog_index_invalidate(prog); } if (prog && name && name->tag == PL_TERM_ATOM) { prog_dyn_pred_remove(prog, name->v.atom_name, (ULO)arity_val); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "current_prolog_flag") && (ar == 2)) { pl_term *flag = deref_term(goal->v.str.args[0], env_in); if (!flag) { return cut_none(); } const pl_unknown_mode unknown_mode = prog ? prog->flag_unknown : PL_UNKNOWN_ERROR; const bool char_conv_on = prog ? prog->flag_char_conversion : false; const bool character_escapes = prog ? prog->flag_character_escapes : true; const bool occurs_check = prog ? prog->flag_occurs_check : false; const bool debug_on = prog ? prog->flag_debug : false; const bool par_or_on = prog ? prog->flag_parallel_or : false; const pl_or_order_mode par_or_order = prog ? prog->flag_parallel_or_order : PL_OR_ORDERED; const bool par_and_on = prog ? prog->flag_parallel_and : false; const SLO par_max_depth = prog ? prog->flag_parallel_max_depth : flowlog_default_parallel_max_depth_auto(); const SLO par_or_nesting = prog ? prog->flag_parallel_or_nesting : (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; const pl_double_quotes_mode dq_mode = prog ? prog->flag_double_quotes : PL_DQ_CHARS; const pl_engine_mode eng_mode = prog ? prog->flag_engine : PL_ENGINE_INTERP; const pl_engine_mode eng_active_mode = g_engine_active; const CHR *unknown_atom = "error"; if (unknown_mode == PL_UNKNOWN_WARNING) { unknown_atom = "warning"; } else if (unknown_mode == PL_UNKNOWN_FAIL) { unknown_atom = "fail"; } const CHR *dq_atom = "codes"; if (dq_mode == PL_DQ_ATOM) { dq_atom = "atom"; } else if (dq_mode == PL_DQ_CHARS) { dq_atom = "chars"; } const CHR *par_or_order_atom = (par_or_order == PL_OR_UNORDERED) ? "unordered" : "ordered"; const bool par_all_on = par_or_on && par_and_on && (par_max_depth > 0); const CHR *par_profile_atom = "custom"; if (!par_or_on && !par_and_on) { par_profile_atom = "off"; } else if (par_all_on) { par_profile_atom = (par_or_order == PL_OR_UNORDERED) ? "fast" : "iso"; } const CHR *engine_atom = "interp"; if (eng_mode == PL_ENGINE_WAM) { engine_atom = "wam"; } else if (eng_mode == PL_ENGINE_WAMVM) { engine_atom = "wamvm"; } const CHR *engine_active_atom = "interp"; if (eng_active_mode == PL_ENGINE_WAM) { engine_active_atom = "wam"; } else if (eng_active_mode == PL_ENGINE_WAMVM) { engine_active_atom = "wamvm"; } if (flag->tag == PL_TERM_VAR) { struct { const CHR *name; pl_term *value; } flags[] = { {"bounded", make_atom_rt(rt_ctrl, dbg_dat_ptr, "false")}, {"max_arity", make_int_rt(rt_ctrl, dbg_dat_ptr, 255)}, {"integer_rounding_function", make_atom_rt(rt_ctrl, dbg_dat_ptr, "toward_zero")}, {"double_quotes", make_atom_rt(rt_ctrl, dbg_dat_ptr, dq_atom)}, {"char_conversion", make_atom_rt(rt_ctrl, dbg_dat_ptr, char_conv_on ? "on" : "off")}, {"character_escapes", make_atom_rt(rt_ctrl, dbg_dat_ptr, character_escapes ? "true" : "false")}, {"occurs_check", make_atom_rt(rt_ctrl, dbg_dat_ptr, occurs_check ? "true" : "false")}, {"debug", make_atom_rt(rt_ctrl, dbg_dat_ptr, debug_on ? "on" : "off")}, {"flowlog_engine", make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_atom)}, {"flowlog_engine_active", make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_active_atom)}, {"flowlog_parallel", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_all_on ? "on" : "off")}, {"flowlog_parallel_profile", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_profile_atom)}, {"flowlog_parallel_or", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_on ? "on" : "off")}, {"flowlog_parallel_or_order", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_order_atom)}, {"flowlog_parallel_and", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_and_on ? "on" : "off")}, {"flowlog_parallel_max_depth", make_int_rt(rt_ctrl, dbg_dat_ptr, par_max_depth)}, {"flowlog_parallel_or_nesting", make_int_rt(rt_ctrl, dbg_dat_ptr, par_or_nesting)}, {"argv", flowlog_build_argv_term(prog, rt_ctrl, dbg_dat_ptr)}, {"unknown", make_atom_rt(rt_ctrl, dbg_dat_ptr, unknown_atom)}, }; for (ULO i = 0; i < (sizeof(flags) / sizeof(flags[0])); i++) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *name_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, flags[i].name); if (!unify_terms(goal->v.str.args[0], name_term, env1, rt_ctrl, dbg_dat_ptr) || !unify_terms(goal->v.str.args[1], flags[i].value, env1, rt_ctrl, dbg_dat_ptr)) { continue; } pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } return cut_none(); } if (flag->tag != PL_TERM_ATOM) { return throw_type_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", flag, env_in, "$legacy_current_prolog_flag", 2); } pl_term *val = NULL; if (!strcmp(flag->v.atom_name, "bounded")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "false"); } else if (!strcmp(flag->v.atom_name, "max_arity")) { val = make_int_rt(rt_ctrl, dbg_dat_ptr, 255); } else if (!strcmp(flag->v.atom_name, "integer_rounding_function")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "toward_zero"); } else if (!strcmp(flag->v.atom_name, "double_quotes")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, dq_atom); } else if (!strcmp(flag->v.atom_name, "char_conversion")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, char_conv_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "character_escapes")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, character_escapes ? "true" : "false"); } else if (!strcmp(flag->v.atom_name, "occurs_check")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, occurs_check ? "true" : "false"); } else if (!strcmp(flag->v.atom_name, "debug")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, debug_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_engine")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_engine_active")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_active_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_all_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_profile")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_profile_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or_order")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_order_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_and")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_and_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_max_depth")) { val = make_int_rt(rt_ctrl, dbg_dat_ptr, par_max_depth); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or_nesting")) { val = make_int_rt(rt_ctrl, dbg_dat_ptr, par_or_nesting); } else if (!strcmp(flag->v.atom_name, "argv")) { val = flowlog_build_argv_term(prog, rt_ctrl, dbg_dat_ptr); } else if (!strcmp(flag->v.atom_name, "unknown")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, unknown_atom); } else { return throw_domain_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "prolog_flag", flag, env_in, "$legacy_current_prolog_flag", 2); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], val, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "set_prolog_flag") && (ar == 2)) { pl_term *flag = deref_term(goal->v.str.args[0], env_in); pl_term *val = deref_term(goal->v.str.args[1], env_in); if (!flag || !val) { return cut_none(); } if (flag->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (flag->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", flag, env_in, "set_prolog_flag", 2); } if (val->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "var"); } const CHR *flag_name = flag->v.atom_name; if (!flag_name) { return cut_none(); } if (!strcmp(flag_name, "unknown")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "error") && strcmp(val->v.atom_name, "warning") && strcmp(val->v.atom_name, "fail"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "unknown"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "error")) { prog->flag_unknown = PL_UNKNOWN_ERROR; } else if (!strcmp(val->v.atom_name, "warning")) { prog->flag_unknown = PL_UNKNOWN_WARNING; } else { prog->flag_unknown = PL_UNKNOWN_FAIL; } } } else if (!strcmp(flag_name, "occurs_check")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "true") && strcmp(val->v.atom_name, "false"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "occurs_check"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_occurs_check = !strcmp(val->v.atom_name, "true"); g_unify_occurs_check = prog->flag_occurs_check; } } else if (!strcmp(flag_name, "char_conversion")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "char_conversion"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_char_conversion = !strcmp(val->v.atom_name, "on"); } } else if (!strcmp(flag_name, "character_escapes")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "true") && strcmp(val->v.atom_name, "false"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "character_escapes"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_character_escapes = !strcmp(val->v.atom_name, "true"); } } else if (!strcmp(flag_name, "double_quotes")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "atom") && strcmp(val->v.atom_name, "codes") && strcmp(val->v.atom_name, "chars"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "double_quotes"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "atom")) { prog->flag_double_quotes = PL_DQ_ATOM; } else if (!strcmp(val->v.atom_name, "codes")) { prog->flag_double_quotes = PL_DQ_CODES; } else { prog->flag_double_quotes = PL_DQ_CHARS; } } } else if (!strcmp(flag_name, "debug")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "debug"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_debug = !strcmp(val->v.atom_name, "on"); } } else if (!strcmp(flag_name, "flowlog_engine")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "interp") && strcmp(val->v.atom_name, "tree") && strcmp(val->v.atom_name, "wam") && strcmp(val->v.atom_name, "wamvm"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_engine"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "wam")) { prog->flag_engine = PL_ENGINE_WAM; } else if (!strcmp(val->v.atom_name, "wamvm")) { prog->flag_engine = PL_ENGINE_WAMVM; } else { prog->flag_engine = PL_ENGINE_INTERP; } } } else if (!strcmp(flag_name, "flowlog_parallel_or")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_or"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_or = !strcmp(val->v.atom_name, "on"); } } else if (!strcmp(flag_name, "flowlog_parallel")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { const bool on = !strcmp(val->v.atom_name, "on"); if (on) { prog->flag_parallel_or = true; prog->flag_parallel_and = true; if (prog->flag_parallel_or_nesting <= 0) { // Enable at least one nested OR-par split so search problems can // utilize more cores than the top-level branching factor. prog->flag_parallel_or_nesting = 1; } } else { prog->flag_parallel_or = false; prog->flag_parallel_and = false; } } } else if (!strcmp(flag_name, "flowlog_parallel_profile")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "off") && strcmp(val->v.atom_name, "iso") && strcmp(val->v.atom_name, "fast"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_profile"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "off")) { prog->flag_parallel_or = false; prog->flag_parallel_and = false; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else if (!strcmp(val->v.atom_name, "iso")) { prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else { // fast prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_UNORDERED; // Enable deeper nesting automatically on very high-core systems so // deep nondet search can keep many CPUs busy when top-level branching // is small (e.g. N-queens with N << cores). SLO nest = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST; const ULO ncpu = get_n_cpuproc(); if (ncpu >= 128) { nest = 8; } else if (ncpu >= 64) { nest = 4; } else if (ncpu >= 32) { nest = 2; } prog->flag_parallel_or_nesting = nest; } } } else if (!strcmp(flag_name, "flowlog_parallel_or_order")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "ordered") && strcmp(val->v.atom_name, "unordered"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_or_order"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_or_order = !strcmp(val->v.atom_name, "unordered") ? PL_OR_UNORDERED : PL_OR_ORDERED; } } else if (!strcmp(flag_name, "flowlog_parallel_and")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_and"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_and = !strcmp(val->v.atom_name, "on"); } } else if (!strcmp(flag_name, "flowlog_parallel_max_depth")) { if (val->tag != PL_TERM_INT) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_max_depth"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (val->v.int_value < 0) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_max_depth"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_max_depth = val->v.int_value; } } else if (!strcmp(flag_name, "flowlog_parallel_or_nesting")) { if (val->tag != PL_TERM_INT) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_or_nesting"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (val->v.int_value < 0) { pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_or_nesting"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, env_in, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_or_nesting = val->v.int_value; } } else if (!strcmp(flag_name, "bounded") || !strcmp(flag_name, "max_arity") || !strcmp(flag_name, "integer_rounding_function") || !strcmp(flag_name, "flowlog_engine_active")) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "flag", flag, env_in, "set_prolog_flag", 2); } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "prolog_flag", flag, env_in, "set_prolog_flag", 2); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "char_conversion") && (ar == 2)) { pl_term *in = deref_term(goal->v.str.args[0], env_in); pl_term *outc = deref_term(goal->v.str.args[1], env_in); if (!in || !outc) { return cut_none(); } if (in->tag == PL_TERM_VAR || outc->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character"); } unsigned char in_code = 0; unsigned char out_code = 0; if (in->tag == PL_TERM_ATOM) { if (!in->v.atom_name || strlen(in->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, env_in, "char_conversion", 2); } in_code = (unsigned char)in->v.atom_name[0]; } else if (in->tag == PL_TERM_INT) { if (in->v.int_value <= 0 || in->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, env_in, "char_conversion", 2); } in_code = (unsigned char)in->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, env_in, "char_conversion", 2); } if (outc->tag == PL_TERM_ATOM) { if (!outc->v.atom_name || strlen(outc->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, env_in, "char_conversion", 2); } out_code = (unsigned char)outc->v.atom_name[0]; } else if (outc->tag == PL_TERM_INT) { if (outc->v.int_value <= 0 || outc->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, env_in, "char_conversion", 2); } out_code = (unsigned char)outc->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, env_in, "char_conversion", 2); } if (prog) { prog->char_conv_table[in_code] = out_code; } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "current_char_conversion") && (ar == 2)) { pl_term *in = deref_term(goal->v.str.args[0], env_in); pl_term *outc = deref_term(goal->v.str.args[1], env_in); if (!in || !outc) { return cut_none(); } const bool in_is_var = (in->tag == PL_TERM_VAR); const bool out_is_var = (outc->tag == PL_TERM_VAR); unsigned char in_code = 0; unsigned char out_code = 0; if (!in_is_var) { if (in->tag == PL_TERM_ATOM) { if (!in->v.atom_name || strlen(in->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, env_in, "current_char_conversion", 2); } in_code = (unsigned char)in->v.atom_name[0]; } else if (in->tag == PL_TERM_INT) { if (in->v.int_value <= 0 || in->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, env_in, "current_char_conversion", 2); } in_code = (unsigned char)in->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, env_in, "current_char_conversion", 2); } } if (!out_is_var) { if (outc->tag == PL_TERM_ATOM) { if (!outc->v.atom_name || strlen(outc->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, env_in, "current_char_conversion", 2); } out_code = (unsigned char)outc->v.atom_name[0]; } else if (outc->tag == PL_TERM_INT) { if (outc->v.int_value <= 0 || outc->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, env_in, "current_char_conversion", 2); } out_code = (unsigned char)outc->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, env_in, "current_char_conversion", 2); } } const unsigned char *tbl = prog ? prog->char_conv_table : NULL; if (!in_is_var) { const unsigned char mapped = tbl ? tbl[in_code] : in_code; if (!out_is_var) { if (mapped != out_code) { return cut_none(); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } CHR tmp[2] = {(CHR)mapped, '\0'}; pl_term *mapped_atom = make_atom_rt(rt_ctrl, dbg_dat_ptr, tmp); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], mapped_atom, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } for (unsigned int c = 1; c <= 255; c++) { if (stop_at_first && *sol_count) { return cut_none(); } const unsigned char mapped = tbl ? tbl[c] : (unsigned char)c; if (!out_is_var && (mapped != out_code)) { continue; } CHR in_tmp[2] = {(CHR)c, '\0'}; CHR out_tmp[2] = {(CHR)mapped, '\0'}; pl_term *in_atom = make_atom_rt(rt_ctrl, dbg_dat_ptr, in_tmp); pl_term *out_atom = make_atom_rt(rt_ctrl, dbg_dat_ptr, out_tmp); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal->v.str.args[0], in_atom, env1, rt_ctrl, dbg_dat_ptr)) { continue; } if (out_is_var && !unify_terms(goal->v.str.args[1], out_atom, env1, rt_ctrl, dbg_dat_ptr)) { continue; } pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "current_rule") && (ar == 1)) { pl_term *pi = deref_term(goal->v.str.args[0], env_in); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "structure"); } if (pi->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "structure", pi, env_in, "current_rule", 1); } if (pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, env_in, "current_rule", 1); } pl_term *name = deref_term(pi->v.str.args[0], env_in); pl_term *arity_term = deref_term(pi->v.str.args[1], env_in); if (!name || !arity_term) { return cut_none(); } if (name->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", pi, env_in, "current_rule", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", pi, env_in, "current_rule", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0 || arity_val > 1024) { return cut_none(); } const CHR *pred_name = name->v.atom_name; const ULO pred_arity = (ULO)arity_val; bool dyn = false; const bool defined = builtin_pred_defined(pred_name, pred_arity) || prog_pred_defined(prog, pred_name, pred_arity, &dyn); if (!defined) { return cut_none(); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "predicate_property") && (ar == 2)) { pl_term *callable = deref_term(goal->v.str.args[0], env_in); if (!callable) { return cut_none(); } if (callable->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (callable->tag != PL_TERM_ATOM && callable->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", callable, env_in, "predicate_property", 2); } pl_term *base = callable; if (base->tag == PL_TERM_STRUCT && base->v.str.arity == 2 && !strcmp(base->v.str.functor, ":")) { base = deref_term(base->v.str.args[1], env_in); } if (!base) { return cut_none(); } if (base->tag != PL_TERM_ATOM && base->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", base, env_in, "predicate_property", 2); } const CHR *pred_name = (base->tag == PL_TERM_ATOM) ? base->v.atom_name : base->v.str.functor; const ULO pred_arity = (base->tag == PL_TERM_ATOM) ? 0 : base->v.str.arity; bool dyn = false; const bool is_builtin = builtin_pred_defined(pred_name, pred_arity); const bool is_user = prog_pred_defined(prog, pred_name, pred_arity, &dyn); if (!is_builtin && !is_user) { return cut_none(); } pl_term *prop = deref_term(goal->v.str.args[1], env_in); if (!prop) { return cut_none(); } if (prop->tag != PL_TERM_VAR) { const bool ok_atom = prop->tag == PL_TERM_ATOM && (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static") || !strcmp(prop->v.atom_name, "dynamic")); const bool ok_template = prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 1 && !strcmp(prop->v.str.functor, "template"); if (!ok_atom && !ok_template) { return throw_domain_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_property", prop, env_in, "$legacy_predicate_property", 2); } } const bool is_dynamic = is_user && dyn; const bool is_static = is_builtin || (is_user && !dyn); // Enumerate properties. if (prop->tag == PL_TERM_VAR) { if (is_builtin && pred_arity == 0 && (!strcmp(pred_name, "true") || !strcmp(pred_name, "!") || !strcmp(pred_name, "fail") || !strcmp(pred_name, "false"))) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "choice_construct"), env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } if (is_builtin) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "built_in"), env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } if (is_static) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "static"), env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } if (is_dynamic) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "dynamic"), env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } if (is_builtin) { // Trealla reports iso for built-ins, but does not accept it as an input property. pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "iso"), env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } // Minimal templates for a few ISO predicates. if (!strcmp(pred_name, "write") && (pred_arity == 1 || pred_arity == 2)) { pl_term *templ = make_struct_rt(rt_ctrl, dbg_dat_ptr, "write", pred_arity); if (pred_arity == 1) { pl_term *m = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m; } else { pl_term *m1 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m1->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "stream"); pl_term *m2 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m2->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m1; templ->v.str.args[1] = m2; } pl_term *pt = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 1); pt->v.str.args[0] = templ; pl_env *env1b = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], pt, env1b, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1b, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } } return cut_none(); } // Property test. if (prop->tag == PL_TERM_ATOM) { if (!strcmp(prop->v.atom_name, "built_in")) { if (is_builtin) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(prop->v.atom_name, "static")) { if (is_static) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(prop->v.atom_name, "dynamic")) { if (is_dynamic) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } } if (prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 1 && !strcmp(prop->v.str.functor, "template")) { if (!is_builtin) { return cut_none(); } if (!strcmp(pred_name, "write") && (pred_arity == 1 || pred_arity == 2)) { pl_term *templ = make_struct_rt(rt_ctrl, dbg_dat_ptr, "write", pred_arity); if (pred_arity == 1) { pl_term *m = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m; } else { pl_term *m1 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m1->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "stream"); pl_term *m2 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m2->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m1; templ->v.str.args[1] = m2; } pl_term *pt = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 1); pt->v.str.args[0] = templ; pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], pt, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } } return cut_none(); } return cut_none(); } if (!strcmp(fn, "evaluable_property") && (ar == 2)) { pl_term *callable = deref_term(goal->v.str.args[0], env_in); if (!callable) { return cut_none(); } if (callable->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (callable->tag != PL_TERM_ATOM && callable->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", callable, env_in, "evaluable_property", 2); } pl_term *prop = deref_term(goal->v.str.args[1], env_in); if (!prop) { return cut_none(); } if (prop->tag != PL_TERM_VAR) { const bool ok_atom = prop->tag == PL_TERM_ATOM && (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static") || !strcmp(prop->v.atom_name, "dynamic")); const bool ok_template = prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 2 && !strcmp(prop->v.str.functor, "template"); if (!ok_atom && !ok_template) { return throw_domain_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable_property", prop, env_in, "$legacy_evaluable_property", 2); } } const CHR *fn_name = NULL; ULO fn_arity = 0; if (callable->tag == PL_TERM_ATOM) { fn_name = callable->v.atom_name; fn_arity = 0; } else { fn_name = callable->v.str.functor; fn_arity = callable->v.str.arity; } // Compute a template(T,R) term for the evaluable functor/constant. pl_term *templ_prop = NULL; if (fn_name && fn_arity == 0 && (!strcmp(fn_name, "e") || !strcmp(fn_name, "epsilon") || !strcmp(fn_name, "pi"))) { templ_prop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, fn_name); templ_prop->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "float"); } else if (fn_name && fn_arity == 1) { const CHR *arg_ty = NULL; const CHR *ret_ty = NULL; if (!strcmp(fn_name, "+") || !strcmp(fn_name, "-") || !strcmp(fn_name, "abs") || !strcmp(fn_name, "sign")) { arg_ty = "number"; ret_ty = "number"; } else if (!strcmp(fn_name, "float")) { arg_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "floor") || !strcmp(fn_name, "ceiling") || !strcmp(fn_name, "truncate") || !strcmp(fn_name, "round")) { arg_ty = "float"; ret_ty = "integer"; } else if (!strcmp(fn_name, "float_integer_part") || !strcmp(fn_name, "float_fractional_part")) { arg_ty = "float"; ret_ty = "float"; } else if (!strcmp(fn_name, "sin") || !strcmp(fn_name, "cos") || !strcmp(fn_name, "tan") || !strcmp(fn_name, "asin") || !strcmp(fn_name, "acos") || !strcmp(fn_name, "atan") || !strcmp(fn_name, "sqrt") || !strcmp(fn_name, "log") || !strcmp(fn_name, "exp")) { arg_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "\\")) { arg_ty = "integer"; ret_ty = "integer"; } if (arg_ty && ret_ty) { pl_term *t = make_struct_rt(rt_ctrl, dbg_dat_ptr, fn_name, 1); t->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, arg_ty); templ_prop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = t; templ_prop->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, ret_ty); } } else if (fn_name && fn_arity == 2) { const CHR *a_ty = NULL; const CHR *b_ty = NULL; const CHR *ret_ty = NULL; if (!strcmp(fn_name, "+") || !strcmp(fn_name, "-") || !strcmp(fn_name, "*") || !strcmp(fn_name, "max") || !strcmp(fn_name, "min")) { a_ty = "number"; b_ty = "number"; ret_ty = "number"; } else if (!strcmp(fn_name, "/")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "//") || !strcmp(fn_name, "div") || !strcmp(fn_name, "mod") || !strcmp(fn_name, "rem") || !strcmp(fn_name, "/\\") || !strcmp(fn_name, "\\/") || !strcmp(fn_name, "xor") || !strcmp(fn_name, "<<") || !strcmp(fn_name, ">>")) { a_ty = "integer"; b_ty = "integer"; ret_ty = "integer"; } else if (!strcmp(fn_name, "**")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "^")) { a_ty = "number"; b_ty = "number"; ret_ty = "integer"; } else if (!strcmp(fn_name, "atan2")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } if (a_ty && b_ty && ret_ty) { pl_term *t = make_struct_rt(rt_ctrl, dbg_dat_ptr, fn_name, 2); t->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, a_ty); t->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, b_ty); templ_prop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = t; templ_prop->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, ret_ty); } } if (!templ_prop) { return cut_none(); } // Enumerate properties. if (prop->tag == PL_TERM_VAR) { const pl_term *props[] = { make_atom_rt(rt_ctrl, dbg_dat_ptr, "built_in"), make_atom_rt(rt_ctrl, dbg_dat_ptr, "static"), make_atom_rt(rt_ctrl, dbg_dat_ptr, "iso"), templ_prop, }; for (ULO i = 0; i < (sizeof(props) / sizeof(props[0])); i++) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal->v.str.args[1], (pl_term *)props[i], env1, rt_ctrl, dbg_dat_ptr)) { continue; } pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } return cut_none(); } if (prop->tag == PL_TERM_ATOM) { if (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static")) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(prop->v.atom_name, "dynamic")) { return cut_none(); } } if (prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 2 && !strcmp(prop->v.str.functor, "template")) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], templ_prop, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } return cut_none(); } if (!strcmp(fn, "current_predicate") && (ar == 1)) { if (!prog) { return cut_none(); } pl_term *pi = deref_term(goal->v.str.args[0], env_in); if (!pi) { return cut_none(); } if (pi->tag != PL_TERM_VAR) { if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, env_in, "current_predicate", 1); } pl_term *name_term = deref_term(pi->v.str.args[0], env_in); pl_term *arity_term = deref_term(pi->v.str.args[1], env_in); if (!name_term || !arity_term) { return cut_none(); } if (name_term->tag != PL_TERM_VAR && name_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, env_in, "current_predicate", 1); } if (arity_term->tag != PL_TERM_VAR) { if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, env_in, "current_predicate", 1); } if (arity_term->v.int_value < 0) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, env_in, "current_predicate", 1); } } } typedef struct { const CHR *name; ULO arity; } pl_pi; ULO cap = 1; cap += prog->clause_count; cap += prog->fact_count; cap += prog->dyn_pred_count; pl_pi *seen = (pl_pi *)pool_alloc(rt_ctrl, sizeof(*seen) * cap, dbg_dat_ptr); ULO seen_count = 0; // Gather clause predicates. if (prog->clauses && prog->clause_count) { for (ULO i = 1; i <= prog->clause_count; i++) { pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { continue; } if (!pred_name) { continue; } bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } // Gather fact predicates (for facts-only programs). if (prog->facts && prog->fact_count) { for (ULO i = 1; i <= prog->fact_count; i++) { const pl_term *h = prog->facts[i]; if (!h) { continue; } const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { continue; } if (!pred_name) { continue; } bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } // Gather dynamic predicate indicators (even if they currently have no clauses). if (prog->dyn_preds && prog->dyn_pred_count) { for (ULO i = 1; i <= prog->dyn_pred_count; i++) { const pl_dyn_pred *dp = &prog->dyn_preds[i]; if (!dp || !dp->name) { continue; } const CHR *pred_name = dp->name; const ULO pred_arity = dp->arity; bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } for (ULO i = 0; i < seen_count; i++) { pl_term *ind = make_struct_rt(rt_ctrl, dbg_dat_ptr, "/", 2); ind->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, seen[i].name); ind->v.str.args[1] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)seen[i].arity); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], ind, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } return cut_none(); } if (!strcmp(fn, "current_op") && (ar == 3)) { const pl_op_overrides *ops = prog ? prog->op_overrides : NULL; for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *base = &PL_OPS[i]; const pl_op_decl *op = base; const pl_op_decl *ov = op_override_find(ops, base->name, base->fix); if (ov) { if (!ov->prec) { continue; // disabled } op = ov; } const CHR *spec = NULL; switch (op->fix) { case PL_OP_INFIX_XFX: spec = "xfx"; break; case PL_OP_INFIX_XFY: spec = "xfy"; break; case PL_OP_INFIX_YFX: spec = "yfx"; break; case PL_OP_PREFIX_FX: spec = "fx"; break; case PL_OP_PREFIX_FY: spec = "fy"; break; case PL_OP_POSTFIX_XF: spec = "xf"; break; case PL_OP_POSTFIX_YF: spec = "yf"; break; } if (!spec) { continue; } pl_term *prec_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)op->prec); pl_term *spec_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, spec); pl_term *name_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, op->name); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal->v.str.args[0], prec_term, env1, rt_ctrl, dbg_dat_ptr) || !unify_terms(goal->v.str.args[1], spec_term, env1, rt_ctrl, dbg_dat_ptr) || !unify_terms(goal->v.str.args[2], name_term, env1, rt_ctrl, dbg_dat_ptr)) { continue; } pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } // Enumerate operators introduced via op/3 that are not present in the base table. if (!ops) { return cut_none(); } for (ULO i = 0; i < ops->count; i++) { const pl_op_decl *op = &ops->items[i]; if (!op->prec) { continue; } bool in_base = false; for (ULO j = 0; j < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); j++) { const pl_op_decl *base = &PL_OPS[j]; if (base->fix == op->fix && !strcmp(base->name, op->name)) { in_base = true; break; } } if (in_base) { continue; } const CHR *spec = NULL; switch (op->fix) { case PL_OP_INFIX_XFX: spec = "xfx"; break; case PL_OP_INFIX_XFY: spec = "xfy"; break; case PL_OP_INFIX_YFX: spec = "yfx"; break; case PL_OP_PREFIX_FX: spec = "fx"; break; case PL_OP_PREFIX_FY: spec = "fy"; break; case PL_OP_POSTFIX_XF: spec = "xf"; break; case PL_OP_POSTFIX_YF: spec = "yf"; break; } if (!spec) { continue; } pl_term *prec_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)op->prec); pl_term *spec_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, spec); pl_term *name_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, op->name); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal->v.str.args[0], prec_term, env1, rt_ctrl, dbg_dat_ptr) || !unify_terms(goal->v.str.args[1], spec_term, env1, rt_ctrl, dbg_dat_ptr) || !unify_terms(goal->v.str.args[2], name_term, env1, rt_ctrl, dbg_dat_ptr)) { continue; } pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "op") && (ar == 3)) { pl_term *prec_term = deref_term(goal->v.str.args[0], env_in); if (!prec_term) { return cut_none(); } if (prec_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (prec_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", prec_term, env_in, "op", 3); } const SLO prec_val = prec_term->v.int_value; if (prec_val < 0 || prec_val > 1200) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "operator_priority", prec_term, env_in, "op", 3); } pl_term *spec_term = deref_term(goal->v.str.args[1], env_in); if (!spec_term) { return cut_none(); } if (spec_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (spec_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", spec_term, env_in, "op", 3); } pl_op_fix fix = PL_OP_INFIX_XFX; if (!strcmp(spec_term->v.atom_name, "xfx")) { fix = PL_OP_INFIX_XFX; } else if (!strcmp(spec_term->v.atom_name, "xfy")) { fix = PL_OP_INFIX_XFY; } else if (!strcmp(spec_term->v.atom_name, "yfx")) { fix = PL_OP_INFIX_YFX; } else if (!strcmp(spec_term->v.atom_name, "fx")) { fix = PL_OP_PREFIX_FX; } else if (!strcmp(spec_term->v.atom_name, "fy")) { fix = PL_OP_PREFIX_FY; } else if (!strcmp(spec_term->v.atom_name, "xf")) { fix = PL_OP_POSTFIX_XF; } else if (!strcmp(spec_term->v.atom_name, "yf")) { fix = PL_OP_POSTFIX_YF; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "operator_specifier", spec_term, env_in, "op", 3); } pl_term *ops_term = deref_term(goal->v.str.args[2], env_in); if (!ops_term) { return cut_none(); } if (ops_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } // Match Trealla behaviour: treat [] and {} as operator names (not a list), so // accept list syntax only for non-empty '.'/2 lists. if (ops_term->tag == PL_TERM_ATOM) { const CHR *name = ops_term->v.atom_name; if (!strcmp(name, ",") ) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "operator", ops_term, env_in, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "create", "operator", ops_term, env_in, "op", 3); } (void)op_override_set(prog, name, fix, (int)prec_val, rt_ctrl, dbg_dat_ptr); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!term_is_list_pair(ops_term)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", ops_term, env_in, "op", 3); } pl_term *cur = ops_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (term_is_nil(cur)) { return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (term_is_list_pair(cur)) { pl_term *h = deref_term(cur->v.str.args[0], env_in); if (!h) { return cut_none(); } if (h->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (h->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", h, env_in, "op", 3); } const CHR *name = h->v.atom_name; if (!strcmp(name, ",")) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "operator", h, env_in, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "create", "operator", h, env_in, "op", 3); } (void)op_override_set(prog, name, fix, (int)prec_val, rt_ctrl, dbg_dat_ptr); cur = cur->v.str.args[1]; continue; } // Trealla accepts '.'/2 lists whose tail is an atom and treats that tail // as an additional operator name (e.g. op(500,xfx,[a|b])). if (cur->tag == PL_TERM_ATOM) { const CHR *name = cur->v.atom_name; if (!strcmp(name, ",")) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "operator", cur, env_in, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "create", "operator", cur, env_in, "op", 3); } (void)op_override_set(prog, name, fix, (int)prec_val, rt_ctrl, dbg_dat_ptr); return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } // Tail is a variable: insufficiently instantiated; otherwise ignore. if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", ops_term, env_in, "op", 3); } if (!strcmp(fn, "dynamic") && (ar == 1)) { pl_term *pis = deref_term(goal->v.str.args[0], env_in); if (!pis) { return cut_none(); } if (pis->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "dynamic", 1); } if (term_is_nil(pis)) { return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } const bool list_mode = term_is_list_pair(pis); const pl_term *cur = pis; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { const pl_term *pi = NULL; if (list_mode) { if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", pis, env_in, "dynamic", 1); } pi = deref_term(cur->v.str.args[0], env_in); cur = deref_term(cur->v.str.args[1], env_in); if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "dynamic", 1); } } else { pi = deref_term((pl_term *)cur, env_in); cur = NULL; } if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "dynamic", 1); } if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", (pl_term *)pi, env_in, "dynamic", 1); } pl_term *name_term = deref_term(pi->v.str.args[0], env_in); pl_term *arity_term = deref_term(pi->v.str.args[1], env_in); if (!name_term || !arity_term) { return cut_none(); } if (name_term->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "dynamic", 1); } if (name_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name_term, env_in, "dynamic", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, env_in, "dynamic", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, env_in, "dynamic", 1); } if (arity_val > 1024) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "dynamic", 1); } const CHR *pred_name = name_term->v.atom_name; const ULO pred_arity = (ULO)arity_val; if (builtin_pred_defined(pred_name, pred_arity)) { pl_term *pi_term = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi_term, env_in, "dynamic", 1); } prog_dyn_pred_add(prog, pred_name, pred_arity, rt_ctrl, dbg_dat_ptr); if (!list_mode) { break; } } return solve_goals( prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (!strcmp(fn, "clause") && (ar == 2)) { pl_term *head_pat = deref_term(goal->v.str.args[0], env_in); pl_term *body_pat = deref_term(goal->v.str.args[1], env_in); if (!head_pat) { return cut_none(); } if (!body_pat) { return cut_none(); } if (head_pat->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (head_pat->tag != PL_TERM_ATOM && head_pat->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", head_pat, env_in, "clause", 2); } if ((body_pat->tag != PL_TERM_VAR) && (body_pat->tag != PL_TERM_ATOM) && (body_pat->tag != PL_TERM_STRUCT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", body_pat, env_in, "clause", 2); } const CHR *pred_name = (head_pat->tag == PL_TERM_ATOM) ? head_pat->v.atom_name : head_pat->v.str.functor; const ULO pred_arity = (head_pat->tag == PL_TERM_ATOM) ? 0 : head_pat->v.str.arity; if (builtin_pred_defined(pred_name, pred_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "access", "private_procedure", pi, env_in, "clause", 2); } bool dyn = false; if (!prog_pred_defined(prog, pred_name, pred_arity, &dyn)) { return cut_none(); // undefined predicate: just fail } if (!dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "access", "private_procedure", pi, env_in, "clause", 2); } if (!prog || !prog->clauses || !prog->clause_count) { return cut_none(); } for (ULO i = 1; i <= prog->clause_count; i++) { pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term *head = clone_term_with_scope(cl->head, cl->scope, scope, rt_ctrl, dbg_dat_ptr); pl_term **body_goals = NULL; if (cl->body_count) { body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = clone_term_with_scope(cl->body[bi + 1], cl->scope, scope, rt_ctrl, dbg_dat_ptr); } } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); body_term = wrap_var_goals_rt(body_term, rt_ctrl, dbg_dat_ptr, 0); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); env_apply_clause_bindings(cl, scope, env1, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], head, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[1], body_term, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } return cut_none(); } if (!strcmp(fn, "var") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && (v->tag == PL_TERM_VAR)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "nonvar") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && (v->tag != PL_TERM_VAR)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "atom") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && (v->tag == PL_TERM_ATOM)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "integer") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && term_is_integer(v)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "float") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && (v->tag == PL_TERM_FLOAT)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "number") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && term_is_number(v)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "atomic") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && term_is_atomic_term(v)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "compound") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && term_is_compound_like(v)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "callable") && (ar == 1)) { pl_term *v = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (v && term_is_callable_like(v)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } // Atom / character / number conversions (ISO core, integers + floats). if (!strcmp(fn, "char_code") && (ar == 2)) { pl_term *ch = deref_term(goal->v.str.args[0], env_in); pl_term *code = deref_term(goal->v.str.args[1], env_in); if (!ch || !code) { return cut_none(); } if ((ch->tag == PL_TERM_VAR) && (code->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "char_code", 2); } if (ch->tag != PL_TERM_VAR) { if (ch->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch, env_in, "char_code", 2); } if (!atom_is_char(ch)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch, env_in, "char_code", 2); } } if (code->tag != PL_TERM_VAR && code->tag != PL_TERM_INT && code->tag != PL_TERM_BIGINT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code, env_in, "char_code", 2); } SLO code_value = 0; if (code->tag == PL_TERM_INT) { code_value = code->v.int_value; } else if (code->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(code->v.bigint, &code_value)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "char_code", 2); } } if (code->tag != PL_TERM_VAR) { if (code_value <= 0 || !unicode_codepoint_valid((uint32_t)code_value)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "char_code", 2); } } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if ((ch->tag == PL_TERM_VAR) && (code->tag != PL_TERM_VAR)) { pl_term *ct = make_char_atom_rt(dbg_dat_ptr, (uint32_t)code_value); if (unify_terms(goal->v.str.args[0], ct, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if ((code->tag == PL_TERM_VAR) && (ch->tag == PL_TERM_ATOM)) { uint32_t cp = 0; if (!atom_codepoint(ch, &cp)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch, env_in, "char_code", 2); } pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)cp); if (unify_terms(goal->v.str.args[1], it, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if ((ch->tag == PL_TERM_ATOM) && (code->tag != PL_TERM_VAR)) { uint32_t cp = 0; if (!atom_codepoint(ch, &cp) || ((SLO)cp != code_value)) { return cut_none(); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if ((!strcmp(fn, "atom_chars") || !strcmp(fn, "atom_codes")) && (ar == 2)) { const bool use_codes = !strcmp(fn, "atom_codes"); pl_term *a = deref_term(goal->v.str.args[0], env_in); pl_term *l = deref_term(goal->v.str.args[1], env_in); if (!a || !l) { return cut_none(); } if ((a->tag == PL_TERM_VAR) && (l->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if ((a->tag != PL_TERM_VAR) && (a->tag != PL_TERM_ATOM)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, env_in, fn, 2); } if (a->tag == PL_TERM_ATOM) { // ISO: validate List is a proper/partial list and that nonvar elements have the right type. pl_term *l_chk = (pl_term *)term_peel_pstr_empty_const(l); if ((l_chk->tag != PL_TERM_VAR) && !term_is_nil(l_chk) && !term_is_list_like_pair(l_chk)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", l_chk, env_in, fn, 2); } if (l->tag != PL_TERM_VAR) { pl_term *cur = goal->v.str.args[1]; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (term_is_list_like_pair(cur) && !term_is_list_pair(cur)) { if (use_codes) { const pl_term *h = NULL; const pl_term *t = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term tail_tmp = {0}; if (!term_list_like_uncons_view(cur, &h, &t, &head_tmp, head_ch, &tail_tmp) || !h || !h->v.atom_name) { return cut_none(); } uint32_t hcp = 0; if (!atom_codepoint(h, &hcp)) { hcp = PL_UTF8_REPLACEMENT; } pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, hcp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, env_in, fn, 2); } // atom_chars: packed strings are valid; validate the continuation tail too. ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } continue; } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], env_in, fn, 2); } pl_term *h = deref_term(cur->v.str.args[0], env_in); if (!h) { return cut_none(); } if (h->tag != PL_TERM_VAR) { if (use_codes) { if (h->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", h, env_in, fn, 2); } } else { if (!atom_is_char(h)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", h, env_in, fn, 2); } } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } } } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); pl_term *list = NULL; if (use_codes) { pl_term *tail = make_nil_rt(dbg_dat_ptr); for (size_t i = n; i > 0; i--) { pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(unsigned char)s[i - 1]); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = it; cons->v.str.args[1] = tail; tail = cons; } list = tail; } else { list = make_pstr_rt(rt_ctrl, dbg_dat_ptr, (const unsigned char *)s, (ULO)n, make_nil_rt(dbg_dat_ptr)); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], list, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } // Construct atom from list. if (l->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if ((l->tag == PL_TERM_PSTR) || term_is_nil(l)) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_env(goal->v.str.args[1], env_in, &pstr_cstr, &pstr_len, &pstr_buf, dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (use_codes && (pstr_len > 0)) { uint32_t cp = 0; (void)utf8_decode_one_lenient(pstr_cstr, (size_t)pstr_len, &cp); if (pstr_buf) { free(pstr_buf); } pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, cp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, env_in, fn, 2); } pl_term *at = make_atom_rt(rt_ctrl, dbg_dat_ptr, (const CHR *)pstr_cstr); if (pstr_buf) { free(pstr_buf); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], at, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (pst == PL_PSTR_CSTR_INSTANTIATION) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } } pl_term_vec elems = {0}; const pl_list_status st = list_to_vec_iso(goal->v.str.args[1], env_in, &elems, dbg_dat_ptr); if (st == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (st != PL_LIST_STATUS_OK) { term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], env_in, fn, 2); } const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term(elems.items[i], env_in); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", e, env_in, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", e, env_in, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } buf[off] = '\0'; term_vec_free(&elems); pl_term *at = make_atom_rt(rt_ctrl, dbg_dat_ptr, buf); free(buf); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], at, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if ((!strcmp(fn, "number_chars") || !strcmp(fn, "number_codes")) && (ar == 2)) { const bool use_codes = !strcmp(fn, "number_codes"); pl_term *n = deref_term(goal->v.str.args[0], env_in); pl_term *l = deref_term(goal->v.str.args[1], env_in); if (!n || !l) { return cut_none(); } if ((n->tag == PL_TERM_VAR) && (l->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if ((n->tag != PL_TERM_VAR) && (n->tag != PL_TERM_INT) && (n->tag != PL_TERM_BIGINT) && (n->tag != PL_TERM_FLOAT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "number", n, env_in, fn, 2); } // If Number is given, accept any List that parses to the same number. // For partial lists (variables in the list), unify with the canonical list. if (n->tag != PL_TERM_VAR) { bool has_var = false; // ISO: validate List is a proper/partial list and that nonvar elements have the right type. pl_term *l_chk = (pl_term *)term_peel_pstr_empty_const(l); if ((l_chk->tag != PL_TERM_VAR) && !term_is_nil(l_chk) && !term_is_list_like_pair(l_chk)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", l_chk, env_in, fn, 2); } if (l->tag != PL_TERM_VAR) { pl_term *cur = goal->v.str.args[1]; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { has_var = true; break; } if (term_is_list_like_pair(cur) && !term_is_list_pair(cur)) { if (use_codes) { const pl_term *h = NULL; const pl_term *t = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term tail_tmp = {0}; if (!term_list_like_uncons_view(cur, &h, &t, &head_tmp, head_ch, &tail_tmp) || !h || !h->v.atom_name) { return cut_none(); } uint32_t hcp = 0; if (!atom_codepoint(h, &hcp)) { hcp = PL_UTF8_REPLACEMENT; } pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, hcp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, env_in, fn, 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } continue; } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], env_in, fn, 2); } pl_term *h = deref_term(cur->v.str.args[0], env_in); if (!h) { return cut_none(); } if (h->tag == PL_TERM_VAR) { has_var = true; } else { if (use_codes) { SLO code = 0; if (h->tag == PL_TERM_INT) { code = h->v.int_value; } else if (h->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(h->v.bigint, &code)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", h, env_in, fn, 2); } if ((code < 0) || (code > 255)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { if (!atom_is_char(h)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", h, env_in, fn, 2); } } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } } } if ((l->tag != PL_TERM_VAR) && !has_var) { pl_parsed_number pn = {0}; bool parsed = false; if (!use_codes && ((l->tag == PL_TERM_PSTR) || term_is_nil(l))) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_env(goal->v.str.args[1], env_in, &pstr_cstr, &pstr_len, &pstr_buf, dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (!parse_number_iso_cstr((const CHR *)pstr_cstr, &pn, rt_ctrl, dbg_dat_ptr)) { if (pstr_buf) { free(pstr_buf); } return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } if (pstr_buf) { free(pstr_buf); } parsed = true; } } if (!parsed) { pl_term_vec elems = {0}; const pl_list_status st_list = list_to_vec_iso(goal->v.str.args[1], env_in, &elems, dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); has_var = true; } else if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], env_in, fn, 2); } else { const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term(elems.items[i], env_in); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); has_var = true; break; } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", e, env_in, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", e, env_in, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } if (!has_var) { buf[off] = '\0'; term_vec_free(&elems); if (!parse_number_iso_cstr(buf, &pn, rt_ctrl, dbg_dat_ptr)) { free(buf); return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } free(buf); } } } if (!has_var) { if (!pn.is_float) { if ((n->tag == PL_TERM_INT) && !pn.is_big && (n->v.int_value == pn.ival)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (n->tag == PL_TERM_BIGINT) { const int cmp = pn.is_big ? bigint_cmp(n->v.bigint, pn.big) : bigint_cmp_slo(n->v.bigint, pn.ival); if (cmp == 0) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } } } else if ((n->tag == PL_TERM_FLOAT) && (n->v.float_value == pn.fval)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } } const size_t tmp_cap = 128; char *tmp_buf = NULL; char *big_buf = NULL; const char *tmp = NULL; if (n->tag == PL_TERM_INT) { tmp_buf = (char *)pool_alloc(rt_ctrl, (ULO)tmp_cap, dbg_dat_ptr); (void)snprintf(tmp_buf, tmp_cap, "%ld", (long)n->v.int_value); tmp = tmp_buf; } else if (n->tag == PL_TERM_BIGINT) { big_buf = bigint_to_cstr(n->v.bigint); if (!big_buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } tmp = big_buf; } else { tmp_buf = (char *)pool_alloc(rt_ctrl, (ULO)tmp_cap, dbg_dat_ptr); float_to_cstr(n->v.float_value, tmp_buf, tmp_cap); tmp = tmp_buf; } const CHR *s = (const CHR *)(tmp ? tmp : ""); const size_t len = strlen(s); pl_term *list = NULL; if (use_codes) { pl_term *tail = make_nil_rt(dbg_dat_ptr); for (size_t i = len; i > 0; i--) { pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(unsigned char)s[i - 1]); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = it; cons->v.str.args[1] = tail; tail = cons; } list = tail; } else { list = make_pstr_rt(rt_ctrl, dbg_dat_ptr, (const unsigned char *)s, (ULO)len, make_nil_rt(dbg_dat_ptr)); } if (big_buf) { free(big_buf); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], list, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } // Parse number from List. if ((l->tag == PL_TERM_PSTR) || term_is_nil(l)) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_env(goal->v.str.args[1], env_in, &pstr_cstr, &pstr_len, &pstr_buf, dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (use_codes && (pstr_len > 0)) { uint32_t cp = 0; (void)utf8_decode_one_lenient(pstr_cstr, (size_t)pstr_len, &cp); if (pstr_buf) { free(pstr_buf); } pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, cp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, env_in, fn, 2); } pl_parsed_number pn = {0}; if (!parse_number_iso_cstr((const CHR *)pstr_cstr, &pn, rt_ctrl, dbg_dat_ptr)) { if (pstr_buf) { free(pstr_buf); } return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } if (pstr_buf) { free(pstr_buf); } pl_term *num = pn.is_float ? make_float_rt(rt_ctrl, dbg_dat_ptr, pn.fval) : (pn.is_big ? make_bigint_rt(rt_ctrl, dbg_dat_ptr, pn.big) : make_int_rt(rt_ctrl, dbg_dat_ptr, pn.ival)); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], num, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (pst == PL_PSTR_CSTR_INSTANTIATION) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } } pl_term_vec elems = {0}; const pl_list_status st = list_to_vec_iso(goal->v.str.args[1], env_in, &elems, dbg_dat_ptr); if (st == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (st != PL_LIST_STATUS_OK) { term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], env_in, fn, 2); } const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term(elems.items[i], env_in); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", e, env_in, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", e, env_in, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } buf[off] = '\0'; term_vec_free(&elems); pl_parsed_number pn = {0}; if (!parse_number_iso_cstr(buf, &pn, rt_ctrl, dbg_dat_ptr)) { free(buf); return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } free(buf); if (n->tag == PL_TERM_VAR) { pl_term *num = pn.is_float ? make_float_rt(rt_ctrl, dbg_dat_ptr, pn.fval) : (pn.is_big ? make_bigint_rt(rt_ctrl, dbg_dat_ptr, pn.big) : make_int_rt(rt_ctrl, dbg_dat_ptr, pn.ival)); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], num, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!pn.is_float) { if ((n->tag == PL_TERM_INT) && !pn.is_big && (n->v.int_value == pn.ival)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (n->tag == PL_TERM_BIGINT) { const int cmp = pn.is_big ? bigint_cmp(n->v.bigint, pn.big) : bigint_cmp_slo(n->v.bigint, pn.ival); if (cmp == 0) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } } } else if ((n->tag == PL_TERM_FLOAT) && (n->v.float_value == pn.fval)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "atom_length") && (ar == 2)) { pl_term *a = deref_term(goal->v.str.args[0], env_in); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, env_in, "atom_length", 2); } pl_term *len_in = deref_term(goal->v.str.args[1], env_in); if (len_in && (len_in->tag != PL_TERM_VAR) && (len_in->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len_in, env_in, "atom_length", 2); } const SLO len = (SLO)strlen(a->v.atom_name ? a->v.atom_name : ""); pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, len); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], it, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "atom_concat") && (ar == 3)) { pl_term *a = deref_term(goal->v.str.args[0], env_in); pl_term *b = deref_term(goal->v.str.args[1], env_in); pl_term *c = deref_term(goal->v.str.args[2], env_in); if (!a || !b || !c) { return cut_none(); } if ((a->tag != PL_TERM_VAR) && (a->tag != PL_TERM_ATOM)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, env_in, "atom_concat", 3); } if ((b->tag != PL_TERM_VAR) && (b->tag != PL_TERM_ATOM)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", b, env_in, "atom_concat", 3); } if ((c->tag != PL_TERM_VAR) && (c->tag != PL_TERM_ATOM)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", c, env_in, "atom_concat", 3); } if ((c->tag == PL_TERM_VAR) && ((a->tag == PL_TERM_VAR) || (b->tag == PL_TERM_VAR))) { // ISO: would enumerate infinitely many solutions. return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom_concat", 3); } if (c->tag == PL_TERM_ATOM) { const CHR *s = c->v.atom_name ? c->v.atom_name : ""; const size_t n = strlen(s); for (size_t i = 0; i <= n; i++) { if (stop_at_first && *sol_count) { return cut_none(); } CHR *p = (CHR *)malloc(i + 1); CHR *qbuf = (CHR *)malloc((n - i) + 1); if (!p || !qbuf) { free(p); free(qbuf); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(p, s, i); p[i] = '\0'; memcpy(qbuf, s + i, n - i); qbuf[n - i] = '\0'; pl_term *pa = make_atom_rt(rt_ctrl, dbg_dat_ptr, p); pl_term *pb = make_atom_rt(rt_ctrl, dbg_dat_ptr, qbuf); free(p); free(qbuf); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], pa, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[1], pb, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } return cut_none(); } // Concatenate A and B to produce C. const CHR *sa = ((pl_term *)a)->v.atom_name ? ((pl_term *)a)->v.atom_name : ""; const CHR *sb = ((pl_term *)b)->v.atom_name ? ((pl_term *)b)->v.atom_name : ""; const size_t na = strlen(sa); const size_t nb = strlen(sb); CHR *buf = (CHR *)malloc(na + nb + 1); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(buf, sa, na); memcpy(buf + na, sb, nb); buf[na + nb] = '\0'; pl_term *cat = make_atom_rt(rt_ctrl, dbg_dat_ptr, buf); free(buf); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[2], cat, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "sub_atom") && (ar == 5)) { pl_term *a = deref_term(goal->v.str.args[0], env_in); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, env_in, "sub_atom", 5); } pl_term *before_t = deref_term(goal->v.str.args[1], env_in); pl_term *len_t = deref_term(goal->v.str.args[2], env_in); pl_term *after_t = deref_term(goal->v.str.args[3], env_in); pl_term *sub_t = deref_term(goal->v.str.args[4], env_in); if (!before_t || !len_t || !after_t || !sub_t) { return cut_none(); } if ((before_t->tag != PL_TERM_VAR) && (before_t->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", before_t, env_in, "sub_atom", 5); } if ((len_t->tag != PL_TERM_VAR) && (len_t->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len_t, env_in, "sub_atom", 5); } if ((after_t->tag != PL_TERM_VAR) && (after_t->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", after_t, env_in, "sub_atom", 5); } if ((sub_t->tag != PL_TERM_VAR) && (sub_t->tag != PL_TERM_ATOM)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", sub_t, env_in, "sub_atom", 5); } const bool before_is_var = (before_t->tag == PL_TERM_VAR); const bool len_is_var = (len_t->tag == PL_TERM_VAR); const bool after_is_var = (after_t->tag == PL_TERM_VAR); const SLO before_fixed = before_is_var ? 0 : before_t->v.int_value; const SLO len_fixed = len_is_var ? 0 : len_t->v.int_value; const SLO after_fixed = after_is_var ? 0 : after_t->v.int_value; if (!before_is_var && (before_fixed < 0)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", before_t, env_in, "sub_atom", 5); } if (!len_is_var && (len_fixed < 0)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", len_t, env_in, "sub_atom", 5); } if (!after_is_var && (after_fixed < 0)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", after_t, env_in, "sub_atom", 5); } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); for (size_t before = 0; before <= n; before++) { if (!before_is_var && ((SLO)before != before_fixed)) { continue; } const size_t max_len = n - before; for (size_t lenv = 0; lenv <= max_len; lenv++) { if (!len_is_var && ((SLO)lenv != len_fixed)) { continue; } const size_t after = n - before - lenv; if (!after_is_var && ((SLO)after != after_fixed)) { continue; } if (stop_at_first && *sol_count) { return cut_none(); } CHR *subbuf = (CHR *)malloc(lenv + 1); if (!subbuf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(subbuf, s + before, lenv); subbuf[lenv] = '\0'; pl_term *suba = make_atom_rt(rt_ctrl, dbg_dat_ptr, subbuf); free(subbuf); pl_term *bt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)before); pl_term *lt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)lenv); pl_term *at = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)after); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], bt, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[2], lt, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[3], at, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[4], suba, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } } return cut_none(); } if (!strcmp(fn, "sub_string") && (ar == 5)) { pl_term *a = deref_term(goal->v.str.args[0], env_in); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, env_in, "sub_string", 5); } pl_term *before_t = deref_term(goal->v.str.args[1], env_in); pl_term *len_t = deref_term(goal->v.str.args[2], env_in); pl_term *after_t = deref_term(goal->v.str.args[3], env_in); pl_term *sub_t = deref_term(goal->v.str.args[4], env_in); if (!before_t || !len_t || !after_t || !sub_t) { return cut_none(); } if ((before_t->tag != PL_TERM_VAR) && (before_t->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", before_t, env_in, "sub_string", 5); } if ((len_t->tag != PL_TERM_VAR) && (len_t->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len_t, env_in, "sub_string", 5); } if ((after_t->tag != PL_TERM_VAR) && (after_t->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", after_t, env_in, "sub_string", 5); } if ((sub_t->tag != PL_TERM_VAR) && (sub_t->tag != PL_TERM_ATOM)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", sub_t, env_in, "sub_string", 5); } const bool before_is_var = (before_t->tag == PL_TERM_VAR); const bool len_is_var = (len_t->tag == PL_TERM_VAR); const bool after_is_var = (after_t->tag == PL_TERM_VAR); const SLO before_fixed = before_is_var ? 0 : before_t->v.int_value; const SLO len_fixed = len_is_var ? 0 : len_t->v.int_value; const SLO after_fixed = after_is_var ? 0 : after_t->v.int_value; if (!before_is_var && (before_fixed < 0)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", before_t, env_in, "sub_string", 5); } if (!len_is_var && (len_fixed < 0)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", len_t, env_in, "sub_string", 5); } if (!after_is_var && (after_fixed < 0)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", after_t, env_in, "sub_string", 5); } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); for (size_t before = 0; before <= n; before++) { if (!before_is_var && ((SLO)before != before_fixed)) { continue; } const size_t max_len = n - before; for (size_t lenv = 0; lenv <= max_len; lenv++) { if (!len_is_var && ((SLO)lenv != len_fixed)) { continue; } const size_t after = n - before - lenv; if (!after_is_var && ((SLO)after != after_fixed)) { continue; } if (stop_at_first && *sol_count) { return cut_none(); } CHR *subbuf = (CHR *)malloc(lenv + 1); if (!subbuf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(subbuf, s + before, lenv); subbuf[lenv] = '\0'; pl_term *suba = make_atom_rt(rt_ctrl, dbg_dat_ptr, subbuf); free(subbuf); pl_term *bt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)before); pl_term *lt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)lenv); pl_term *at = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)after); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], bt, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[2], lt, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[3], at, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[4], suba, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } } } return cut_none(); } // List operations (ISO). if (!strcmp(fn, "length") && (ar == 2)) { pl_term *list0 = deref_term(goal->v.str.args[0], env_in); pl_term *len0 = deref_term(goal->v.str.args[1], env_in); if (!list0 || !len0) { return cut_none(); } const bool list_is_var = (list0->tag == PL_TERM_VAR); const bool len_is_var = (len0->tag == PL_TERM_VAR); if (!len_is_var && (len0->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len0, env_in, "length", 2); } if (!len_is_var && (len0->v.int_value < 0)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", len0, env_in, "length", 2); } if (len_is_var) { // Generator when both arguments are variables. if (list_is_var) { for (SLO n = 0; !FLOWLOG_DEPTH_LIMIT_EXCEEDED((ULO)n, FLOWLOG_DEPTH_LIMIT); n++) { if (stop_at_first && *sol_count) { return cut_none(); } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term *tail = make_nil_rt(dbg_dat_ptr); for (SLO i = n; i > 0; i--) { pl_term *v = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, scope, (ULO)(i - 1)); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = v; cons->v.str.args[1] = tail; tail = cons; } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *nt = make_int_rt(rt_ctrl, dbg_dat_ptr, n); if (unify_terms(goal->v.str.args[0], tail, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[1], nt, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } if (n == LONG_MAX) { break; } } return cut_none(); } // Compute list length. If we encounter an open tail variable, close it to []. pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *cur = deref_term(goal->v.str.args[0], env1); pl_term *hare = cur; bool hare_ok = true; SLO count = 0; for (;;) { cur = deref_term(cur, env1); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur)) { pl_term *ct = make_int_rt(rt_ctrl, dbg_dat_ptr, count); if (unify_terms(goal->v.str.args[1], ct, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (term_is_pstr_nonempty(cur)) { ULO seg_len = 0; const pl_term *tail = NULL; if (!term_pstr_run_len_and_tail_peeled_const(cur, &seg_len, &tail)) { return cut_none(); } if (seg_len > (ULO)(LONG_MAX - count)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } count += (SLO)seg_len; hare_ok = false; cur = (pl_term *)(tail ? tail : make_nil_rt(dbg_dat_ptr)); continue; } if (cur->tag == PL_TERM_VAR) { pl_term *nil = make_nil_rt(dbg_dat_ptr); if (!unify_terms(cur, nil, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } pl_term *ct = make_int_rt(rt_ctrl, dbg_dat_ptr, count); if (unify_terms(goal->v.str.args[1], ct, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, env_in, "length", 2); } if (count == LONG_MAX) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } count++; // Floyd cycle detection to avoid infinite loops on cyclic lists. if (hare_ok) { for (int step = 0; step < 2; step++) { hare = deref_term(hare, env1); if (!hare) { hare_ok = false; break; } if (term_is_nil(hare) || hare->tag == PL_TERM_VAR) { hare_ok = false; break; } if (!term_is_list_pair(hare)) { // `cur` will throw the correct type error once it reaches this node. hare_ok = false; break; } hare = hare->v.str.args[1]; } if (hare_ok && hare == cur) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } } cur = cur->v.str.args[1]; } } // Fixed length: enforce list length, instantiating open tails. const SLO target = len0->v.int_value; pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); pl_term *cur = deref_term(goal->v.str.args[0], env1); for (SLO i = 0; i < target; i++) { cur = deref_term(cur, env1); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_list_pair(cur)) { cur = cur->v.str.args[1]; continue; } if (term_is_pstr_nonempty(cur)) { ULO seg_len = 0; const pl_term *tail = NULL; if (!term_pstr_run_len_and_tail_peeled_const(cur, &seg_len, &tail)) { return cut_none(); } const SLO remaining = target - i; if (remaining <= 0 || seg_len > (ULO)remaining) { return cut_none(); } i += (SLO)seg_len - 1; cur = (pl_term *)(tail ? tail : make_nil_rt(dbg_dat_ptr)); continue; } if (term_is_nil(cur)) { return cut_none(); } if (cur->tag == PL_TERM_VAR) { const SLO remaining = target - i; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term *tail = make_nil_rt(dbg_dat_ptr); for (SLO j = remaining; j > 0; j--) { pl_term *v = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, scope, (ULO)(j - 1)); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = v; cons->v.str.args[1] = tail; tail = cons; } if (!unify_terms(cur, tail, env1, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } cur = tail->v.str.args[1]; continue; } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, env_in, "length", 2); } cur = deref_term(cur, env1); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } if (cur->tag == PL_TERM_VAR) { pl_term *nil = make_nil_rt(dbg_dat_ptr); if (unify_terms(cur, nil, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (term_is_list_pair(cur)) { return cut_none(); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, env_in, "length", 2); } // Fast pruning helper for search-heavy examples. // // bounds_possible(+SortedInts, +K, +Target) // // True if Target is between the minimum possible sum of K elements (sum of // the K smallest) and the maximum possible sum of K elements (sum of the K // largest). This is a deterministic test predicate (no bindings). if (!strcmp(fn, "bounds_possible") && (ar == 3)) { pl_term *list0 = deref_term(goal->v.str.args[0], env_in); pl_term *k0 = deref_term(goal->v.str.args[1], env_in); pl_term *t0 = deref_term(goal->v.str.args[2], env_in); if (!list0 || !k0 || !t0) { return cut_none(); } if (k0->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", k0, env_in, "bounds_possible", 3); } if (t0->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", t0, env_in, "bounds_possible", 3); } const SLO k = k0->v.int_value; const SLO target = t0->v.int_value; if (k <= 0) { if (target == 0) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (k > 256) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "bounds_possible", 3); } SLO min_sum = 0; SLO last_sum = 0; const ULO ring_cap = (ULO)k; SLO *ring = (SLO *)pool_alloc(rt_ctrl, (ULO)(sizeof(*ring) * ring_cap), dbg_dat_ptr); ULO ring_count = 0; ULO ring_pos = 0; pl_term *cur = list0; ULO count = 0; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, env_in, "bounds_possible", 3); } pl_term *h = deref_term(cur->v.str.args[0], env_in); if (!h) { return cut_none(); } if (h->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", h, env_in, "bounds_possible", 3); } const SLO v = h->v.int_value; count++; if ((SLO)count <= k) { min_sum += v; } if (ring_count < ring_cap) { ring[ring_count++] = v; last_sum += v; } else { last_sum -= ring[ring_pos]; ring[ring_pos] = v; last_sum += v; ring_pos++; if (ring_pos >= ring_cap) { ring_pos = 0; } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "bounds_possible", 3); } } if ((SLO)count < k) { return cut_none(); } const SLO max_sum = last_sum; if (target < min_sum || target > max_sum) { return cut_none(); } return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } // List operations (de-facto standard, used heavily by examples). if ((!strcmp(fn, "select1") || !strcmp(fn, "select_") || !strcmp(fn, "select")) && (ar == 3)) { pl_term *list0 = deref_term(goal->v.str.args[1], env_in); if (!list0) { return cut_none(); } if (term_is_nil(list0)) { return cut_none(); } if (!term_is_list_pair(list0)) { // Fall back to the relational definition for vars/partial lists. pl_term *rel = build_select_relational_rt(rt_ctrl, dbg_dat_ptr, fn, goal->v.str.args[0], goal->v.str.args[1], goal->v.str.args[2]); const ULO rest = goal_count ? (goal_count - 1) : 0; const ULO new_goal_count = 1 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = rel; for (ULO i = 1; i < goal_count; i++) { new_goals[i] = goals[i]; } return solve_goals(prog, q, new_goals, new_goal_count, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } const CHR *cons_functor = list0->v.str.functor; pl_list_cycle_info cycle = {0}; const bool has_cycle = list_pair_cycle_info_tr(list0, env_in, &cycle); const ULO cycle_start = has_cycle ? cycle.prefix_len : 0; const ULO cycle_end = has_cycle ? (cycle.prefix_len + cycle.cycle_len) : 0; if (has_cycle && g_unify_occurs_check) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } // OR-par split: for large enough lists, treat select1/3 as a high-quality choicepoint for work-stealing OR-par. // // This is a key enabler for automatically-parallel search problems (e.g. magic squares) where branching comes // from deep nondet generators rather than many predicate clauses. // // Performance note: counting the list length requires a full traversal. We avoid this work unless OR-par is // actually possible (enabled + nesting allows it + worker budget available). bool can_orpar = prog && g_par_state && (g_table_state == NULL) && ((SLO)g_orpar_level <= prog->flag_parallel_or_nesting) && prog->flag_parallel_or && (prog->flag_parallel_max_depth > 0) && !stop_at_first && ((on_solution == NULL) || (prog->flag_parallel_or_order == PL_OR_UNORDERED)); if (can_orpar && g_par_budget) { if (atomic_load_explicit(g_par_budget, memory_order_relaxed) <= 0) { can_orpar = false; } } if (has_cycle) { can_orpar = false; } ULO alt_count = 0; if (can_orpar) { pl_term *lc = list0; while (1) { lc = deref_term(lc, env_in); if (!lc) { return cut_none(); } if (term_is_nil(lc)) { break; } if (!term_is_list_pair(lc)) { break; } alt_count++; lc = lc->v.str.args[1]; } } const bool par_or = can_orpar && (alt_count >= (ULO)FLOWLOG_SELECT1_ORPAR_DEEP_THRESHOLD); if (par_or && (alt_count >= FLOWLOG_ORPAR_MIN_ALT_THRESHOLD)) { const uint64_t orpar_t0 = flowlog_monotonic_ns(); const CHR *pred = "select1"; const ULO pred_arity = 3; ULO worker_count = (ULO)g_par_state->max_threads; if (worker_count < 2) { worker_count = 2; } if (worker_count > alt_count) { worker_count = alt_count; } int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } if (worker_count >= 2) { ULO chunk_count = worker_count * 128; const ULO chunk_cap = 16384; if (chunk_count > chunk_cap) { chunk_count = chunk_cap; } if (chunk_count > alt_count) { chunk_count = alt_count; } if (!chunk_count) { chunk_count = alt_count; } flowlog_debug_orpar_log_start(pred, pred_arity, alt_count, worker_count, chunk_count, depth, stop_at_first); pl_or_job *workers = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*workers) * worker_count, dbg_dat_ptr); memset(workers, 0, sizeof(*workers) * worker_count); pl_or_job *chunks = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*chunks) * chunk_count, dbg_dat_ptr); memset(chunks, 0, sizeof(*chunks) * chunk_count); pl_or_work *work = (pl_or_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->count = worker_count; work->jobs = workers; work->chunk_count = chunk_count; work->chunks = chunks; work->unordered = (prog->flag_parallel_or_order == PL_OR_UNORDERED); atomic_init(&work->next_chunk, 0); atomic_init(&work->commit_chunk, 0); atomic_init(&work->max_chunk, (unsigned long)(chunk_count ? (chunk_count - 1) : 0)); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; atomic_init(&work->budget_returned, 0); work->budget_total = remote_taken; work->dbg_t0_ns = orpar_t0; atomic_init(&work->dbg_first_cut_chunk, (unsigned long)ULONG_MAX); for (ULO i = 0; i < chunk_count; i++) { const ULO start = (ULO)(((unsigned __int128)i * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); ULO end = (ULO)(((unsigned __int128)(i + 1) * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); if (end > alt_count) { end = alt_count; } chunks[i] = (pl_or_job){ .kind = PL_OR_JOB_SELECT1_RANGE, .prog = prog, .q = q, .goal = goal, .env_in = env_in, .drop = NULL, .rest_goals = (pl_term *const *)(goals + 1), .rest_count = goal_count ? (goal_count - 1) : 0, .cut_barrier = cut_barrier, .exc_barrier = exc_barrier, .depth = depth, .stop_at_first = stop_at_first, .capture_solution_output = (out != NULL) || (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .capture_solution_spans = (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .on_solution = on_solution, .on_solution_ctx = on_solution_ctx, .on_solution_safe_temp_release = g_on_solution_safe_temp_release, // Use process-local allocation for query-temporary objects to // reduce shared-memory allocator contention in OR-par workers. .local_alloc_ok = true, .stringify_exceptions = false, .chunk_index = i, .work_done = NULL, .work_cancel = &work->cancel, }; atomic_init(&chunks[i].done, 0); chunks[i].u.select1_range.list0 = list0; chunks[i].u.select1_range.cons_functor = cons_functor; chunks[i].u.select1_range.start = start; chunks[i].u.select1_range.end = end; } for (ULO i = 0; i < worker_count; i++) { workers[i] = (pl_or_job){ .kind = PL_OR_JOB_WORKER, .prog = prog, .work_done = &work->done, .work_cancel = &work->cancel, }; workers[i].u.worker.work = work; workers[i].budget_return = (i == 0) ? 0 : 1; atomic_init(&workers[i].done, 0); } pl_cut_signal ret = cut_none(); bool stopped = false; const ULO started = flowlog_start_or_work(work, 2, rt_ctrl, dbg_dat_ptr); if (g_par_budget && remote_taken && ((int)started < remote_taken)) { par_global_budget_give(g_par_budget, remote_taken - (int)started); remote_taken = (int)started; work->budget_total = remote_taken; } if (!work->unordered) { ULO last_done = 0; for (ULO i = 0; i < chunk_count; i++) { atomic_store(&work->commit_chunk, (unsigned long)i); pl_or_job *j = &chunks[i]; while (!atomic_load(&j->done)) { if (flowlog_cancelled()) { break; } // Help progress work while waiting for ordered chunk i to complete. unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); last_done = i + 1; if (stopped) { break; } } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); if (stopped && (last_done < chunk_count)) { for (ULO i = last_done; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } } else { ULO done_count = 0; ULO scan = 0; pl_or_job *stop_job = NULL; while (done_count < chunk_count) { if (flowlog_cancelled()) { break; } bool progressed = false; for (ULO n = 0; n < chunk_count; n++) { const ULO idx = (scan + n) % chunk_count; pl_or_job *j = &chunks[idx]; const int done = atomic_load(&j->done); if (done != 1) { continue; } done_count++; scan = idx + 1; progressed = true; pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } if (j->sig.cut) { ret = j->sig; stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); atomic_store(&j->done, 2); } if (stopped) { break; } if (progressed) { continue; } if (atomic_load_explicit(&work->cancel, memory_order_relaxed)) { usleep(1000); continue; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); for (ULO i = 0; i < chunk_count; i++) { pl_or_job *j = &chunks[i]; if (j == stop_job) { continue; } if (atomic_load(&j->done) == 2) { continue; } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); } if (stop_job) { pl_or_job_dispose(stop_job, rt_ctrl, dbg_dat_ptr); } } flowlog_debug_orpar_log_stop(pred, pred_arity, alt_count, flowlog_monotonic_ns() - orpar_t0, stopped, atomic_load(&work->cancel) != 0); return ret; } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } const size_t prefix_cap = 256; pl_term **prefix = (pl_term **)pool_alloc(rt_ctrl, (ULO)(sizeof(*prefix) * prefix_cap), dbg_dat_ptr); size_t prefix_count = 0; pl_term *cur = list0; ULO idx = 0; pl_list_cycle_guard cg; if (!has_cycle) { list_cycle_guard_init(&cg, cur); } while (1) { const pl_cut_signal lim = flowlog_inference_limit_tick(exc_barrier, rt_ctrl, dbg_dat_ptr); if (lim.except) { return lim; } if (has_cycle && (idx == cycle_end)) { idx = cycle_start; if (prefix_count > cycle_start) { prefix_count = cycle_start; } } cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { return cut_none(); } if (!term_is_list_pair(cur)) { return cut_none(); } pl_term *head = cur->v.str.args[0]; pl_term *tail = cur->v.str.args[1]; if (stop_at_first && *sol_count) { return cut_none(); } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } // Build Rest = Prefix ++ Tail. pl_term *rest = tail; if (prefix_count) { const size_t align = sizeof(void *); const size_t term_bytes = prefix_count * sizeof(pl_term); const size_t term_bytes_aligned = (term_bytes + align - 1) & ~(align - 1); const size_t args_bytes = prefix_count * 2 * sizeof(pl_term *); const size_t total_bytes = term_bytes_aligned + args_bytes; void *mem = pool_alloc(rt_ctrl, (ULO)total_bytes, dbg_dat_ptr); pl_term *terms = (pl_term *)mem; pl_term **args = (pl_term **)((char *)mem + term_bytes_aligned); for (size_t i = prefix_count; i > 0; i--) { const size_t idx = prefix_count - i; pl_term *cons = &terms[idx]; cons->tag = PL_TERM_STRUCT; cons->builtin = 0; cons->reserved16 = 0; cons->v.str.arity = 2; cons->v.str.functor = (CHR *)(cons_functor ? cons_functor : "."); cons->v.str.args = &args[idx * 2]; cons->v.str.args[0] = prefix[i - 1]; cons->v.str.args[1] = rest; rest = cons; } } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], head, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[2], rest, env1, rt_ctrl, dbg_dat_ptr)) { pl_cut_signal r = solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.cut || r.except) { return r; } } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (prefix_count < prefix_cap) { prefix[prefix_count++] = head; } else { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } cur = tail; idx++; if (!has_cycle && list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } } return cut_none(); } if (!strcmp(fn, "keysort") && (ar == 2)) { pl_term_vec v = {0}; const pl_list_status st = list_to_vec_iso(goal->v.str.args[0], env_in, &v, dbg_dat_ptr); if (st == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st == PL_LIST_STATUS_TYPE_ERROR) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[0], env_in, "keysort", 2); } if (v.count) { for (ULO i = 0; i < v.count; i++) { pl_term *t = deref_term(v.items[i], env_in); if (!t) { term_vec_free(&v); return cut_none(); } if (t->tag == PL_TERM_VAR) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if ((t->tag != PL_TERM_STRUCT) || (t->v.str.arity != 2) || strcmp(t->v.str.functor, "-")) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "pair", t, env_in, "keysort", 2); } v.items[i] = t; } // Stable insertion sort by Key (first arg). for (ULO i = 1; i < v.count; i++) { pl_term *pair = v.items[i]; pl_term *key = pair->v.str.args[0]; ULO j = i; while (j > 0) { pl_term *prev = v.items[j - 1]; pl_term *prev_key = prev->v.str.args[0]; if (compare_std_terms_env(prev_key, key, env_in, dbg_dat_ptr) <= 0) { break; } v.items[j] = prev; j--; } v.items[j] = pair; } } // Validate output argument is list/partial list and (if given) a list of pairs. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term(out0, env_in); if (!out_term) { term_vec_free(&v); return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", out0, env_in, "keysort", 2); } pl_term *h = NULL; pl_term *tail = NULL; if (!term_list_like_uncons_rt(cur, &h, &tail, rt_ctrl, dbg_dat_ptr) || !h || !tail) { term_vec_free(&v); return cut_none(); } pl_term *e = deref_term(h, env_in); if (!e) { term_vec_free(&v); return cut_none(); } if (e->tag != PL_TERM_VAR) { if ((e->tag != PL_TERM_STRUCT) || (e->v.str.arity != 2) || strcmp(e->v.str.functor, "-")) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "pair", e, env_in, "keysort", 2); } } cur = tail; if (list_cycle_guard_step_tr(&cg, env_in)) { term_vec_free(&v); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "keysort", 2); } } } pl_term *list = build_list_rt(rt_ctrl, dbg_dat_ptr, v.items, v.count); term_vec_free(&v); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], list, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "sort") && (ar == 2)) { pl_term_vec v = {0}; const pl_list_status st = list_to_vec_iso(goal->v.str.args[0], env_in, &v, dbg_dat_ptr); if (st == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st == PL_LIST_STATUS_TYPE_ERROR) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[0], env_in, "sort", 2); } // Validate output argument is list/partial list. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term(out0, env_in); if (!out_term) { term_vec_free(&v); return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", out0, env_in, "sort", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_tr(&cg, env_in)) { term_vec_free(&v); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "sort", 2); } } } if (v.count) { g_qsort_env = env_in; g_qsort_dbg_dat_ptr = dbg_dat_ptr; qsort(v.items, (size_t)v.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp); g_qsort_env = NULL; g_qsort_dbg_dat_ptr = NULL; } ULO uniq = 0; for (ULO i = 0; i < v.count; i++) { if (!uniq || (compare_std_terms_env(v.items[i], v.items[uniq - 1], env_in, dbg_dat_ptr) != 0)) { v.items[uniq++] = v.items[i]; } } pl_term *list = build_list_rt(rt_ctrl, dbg_dat_ptr, v.items, uniq); term_vec_free(&v); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], list, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "msort") && (ar == 2)) { pl_term_vec v = {0}; if (!list_to_vec(goal->v.str.args[0], env_in, &v, dbg_dat_ptr)) { term_vec_free(&v); return cut_none(); } if (v.count) { g_qsort_env = env_in; g_qsort_dbg_dat_ptr = dbg_dat_ptr; qsort(v.items, (size_t)v.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp); g_qsort_env = NULL; g_qsort_dbg_dat_ptr = NULL; } pl_term *list = build_list_rt(rt_ctrl, dbg_dat_ptr, v.items, v.count); term_vec_free(&v); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], list, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } // Term operations (ISO core). if (!strcmp(fn, "ground") && (ar == 1)) { pl_var_stack st; var_stack_init(&st); const bool ok = term_is_ground_tr(goal->v.str.args[0], env_in, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (ok) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "acyclic_term") && (ar == 1)) { pl_var_stack st; var_stack_init(&st); const bool ok = term_is_acyclic_tr(goal->v.str.args[0], env_in, &st, dbg_dat_ptr, 0); var_stack_free(&st); if (ok) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "term_variables") && (ar == 2)) { // Validate output argument is list/partial list. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term(out0, env_in); if (!out_term) { return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", out0, env_in, "term_variables", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "term_variables", 2); } } } pl_var_stack st; pl_var_list vl; var_stack_init(&st); var_list_init(&vl); term_collect_vars_tr(goal->v.str.args[0], env_in, &st, &vl, dbg_dat_ptr, 0); var_stack_free(&st); pl_term *list = NULL; if (!vl.count) { list = make_nil_rt(dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * vl.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < vl.count; i++) { elems[i] = vl.items[i].term; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, vl.count); free(elems); } var_list_free(&vl); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], list, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "copy_term") && (ar == 2)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); const pl_scope *copy_scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(pl_scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, copy_scope); pl_term *copied = copy_term_tr(goal->v.str.args[0], env_in, env1, &m, rt_ctrl, dbg_dat_ptr, 0); copy_var_map_free(&m); if (copied && unify_terms(goal->v.str.args[1], copied, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "numbervars") && (ar == 3)) { pl_term *start_term = deref_term(goal->v.str.args[1], env_in); if (!start_term || (start_term->tag == PL_TERM_VAR)) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (start_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", start_term, env_in, "numbervars", 3); } pl_term *end_term = deref_term(goal->v.str.args[2], env_in); if (end_term && (end_term->tag != PL_TERM_VAR) && (end_term->tag != PL_TERM_INT)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", end_term, env_in, "numbervars", 3); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); SLO counter = start_term->v.int_value; pl_var_stack st; var_stack_init(&st); const bool ok = term_numbervars_tr(goal->v.str.args[0], env1, &st, &counter, rt_ctrl, dbg_dat_ptr, 0); var_stack_free(&st); if (!ok) { return cut_none(); } pl_term *end_val = make_int_rt(rt_ctrl, dbg_dat_ptr, counter); if (unify_terms(goal->v.str.args[2], end_val, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "functor") && (ar == 3)) { pl_term *t = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (t && (t->tag != PL_TERM_VAR)) { pl_term *name = NULL; SLO arity_val = 0; if (!term_functor_arity_rt(t, &name, &arity_val, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } pl_term *arity_term = make_int_rt(rt_ctrl, dbg_dat_ptr, arity_val); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], name, env1, rt_ctrl, dbg_dat_ptr) && unify_terms(goal->v.str.args[2], arity_term, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } // Construct a term from Name/Arity. pl_term *name = deref_term(goal->v.str.args[1], env_in); pl_term *arity_term = deref_term(goal->v.str.args[2], env_in); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, env_in, "functor", 3); } const SLO n = arity_term->v.int_value; if (n < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, env_in, "functor", 3); } const SLO max_arity = 255; // current_prolog_flag(max_arity, 255) if (n > max_arity) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "functor", 3); } if (name->tag != PL_TERM_ATOM && name->tag != PL_TERM_INT && name->tag != PL_TERM_FLOAT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atomic", name, env_in, "functor", 3); } if (n == 0) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], name, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (name->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name, env_in, "functor", 3); } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term *ct = make_struct_rt(rt_ctrl, dbg_dat_ptr, name->v.atom_name, (ULO)n); for (ULO i = 0; i < (ULO)n; i++) { ct->v.str.args[i] = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, scope, i); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], ct, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "arg") && (ar == 3)) { pl_term *n = deref_term(goal->v.str.args[0], env_in); if (!n) { return cut_none(); } if (n->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (n->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", n, env_in, "arg", 3); } pl_term *t = deref_term_and_peel_pstr_empty(goal->v.str.args[1], env_in); if (!t) { return cut_none(); } if (t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (!term_is_compound_like(t)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "compound", t, env_in, "arg", 3); } const SLO idx = n->v.int_value; if (idx < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", n, env_in, "arg", 3); } const ULO arity = term_compound_arity(t); if (idx == 0 || (ULO)idx > arity) { return cut_none(); } pl_term *val = NULL; if (!term_compound_arg_rt(t, idx, &val, rt_ctrl, dbg_dat_ptr) || !val) { return cut_none(); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[2], val, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "=..") && (ar == 2)) { pl_term *t = deref_term_and_peel_pstr_empty(goal->v.str.args[0], env_in); if (t && (t->tag != PL_TERM_VAR)) { // Validate list argument is a (proper or partial) list. pl_term *list0 = goal->v.str.args[1]; pl_term *list_term = deref_term(list0, env_in); if (!list_term) { return cut_none(); } if (list_term->tag != PL_TERM_VAR) { pl_term *cur = list_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, env_in, "=..", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "=..", 2); } } } pl_term *list = NULL; if (term_is_compound_like(t)) { pl_term *fname = NULL; SLO arity_val = 0; if (!term_functor_arity_rt(t, &fname, &arity_val, rt_ctrl, dbg_dat_ptr) || !fname || (fname->tag != PL_TERM_ATOM) || (arity_val < 0)) { return cut_none(); } const ULO n = (ULO)arity_val; pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * (n + 1)); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } elems[0] = fname; for (ULO i = 0; i < n; i++) { pl_term *argi = NULL; if (!term_compound_arg_rt(t, (SLO)i + 1, &argi, rt_ctrl, dbg_dat_ptr) || !argi) { free(elems); return cut_none(); } elems[i + 1] = argi; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, n + 1); free(elems); } else { pl_term *elems[1] = {t}; list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, 1); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[1], list, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } // Construct term from list. pl_term_vec v = {0}; const pl_list_status st = list_to_vec_iso(goal->v.str.args[1], env_in, &v, dbg_dat_ptr); if (st == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st == PL_LIST_STATUS_TYPE_ERROR || (v.count == 0)) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], env_in, "=..", 2); } pl_term *head = deref_term(v.items[0], env_in); if (!head) { term_vec_free(&v); return cut_none(); } if (head->tag == PL_TERM_VAR) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_term *res = NULL; if (v.count == 1) { if (head->tag != PL_TERM_ATOM && head->tag != PL_TERM_INT && head->tag != PL_TERM_FLOAT) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atomic", head, env_in, "=..", 2); } res = head; } else { if (head->tag != PL_TERM_ATOM) { term_vec_free(&v); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", head, env_in, "=..", 2); } const ULO n = v.count - 1; if (n > 255) { term_vec_free(&v); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "=..", 2); } pl_term *st = make_struct_rt(rt_ctrl, dbg_dat_ptr, head->v.atom_name, n); for (ULO i = 0; i < n; i++) { st->v.str.args[i] = v.items[i + 1]; } res = st; } term_vec_free(&v); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], res, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "unify_with_occurs_check") && (ar == 2)) { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms_occurs(goal->v.str.args[0], goal->v.str.args[1], env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "subsumes_term") && (ar == 2)) { pl_term *pair = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$subsumes_pair", 2); pair->v.str.args[0] = goal->v.str.args[0]; pair->v.str.args[1] = goal->v.str.args[1]; pl_env *copy_env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_copy_var_map m; copy_var_map_init(&m, scope); pl_term *pair_c = copy_term_tr(pair, env_in, copy_env, &m, rt_ctrl, dbg_dat_ptr, 0); copy_var_map_free(&m); if (!pair_c || (pair_c->tag != PL_TERM_STRUCT) || strcmp(pair_c->v.str.functor, "$subsumes_pair") || (pair_c->v.str.arity != 2)) { return cut_none(); } pl_term *gen = pair_c->v.str.args[0]; pl_term *spec = pair_c->v.str.args[1]; if (!gen || !spec) { return cut_none(); } pl_var_stack st; pl_var_list rigid; var_stack_init(&st); var_list_init(&rigid); term_collect_vars_tr(spec, copy_env, &st, &rigid, dbg_dat_ptr, 0); var_stack_free(&st); const bool ok = unify_terms_subsumes(gen, spec, copy_env, &rigid, rt_ctrl, dbg_dat_ptr, 0); var_list_free(&rigid); if (ok) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "compare") && (ar == 3)) { pl_term *ord0 = deref_term(goal->v.str.args[0], env_in); if (!ord0) { return cut_none(); } if (ord0->tag != PL_TERM_VAR) { if (ord0->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", ord0, env_in, "compare", 3); } if (strcmp(ord0->v.atom_name, "<") && strcmp(ord0->v.atom_name, ">") && strcmp(ord0->v.atom_name, "=")) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "order", ord0, env_in, "compare", 3); } } pl_var_stack st; var_stack_init(&st); const int r = compare_std_terms(goal->v.str.args[1], goal->v.str.args[2], env_in, &st, dbg_dat_ptr, 0); var_stack_free(&st); const CHR *sym = (r < 0) ? "<" : (r > 0) ? ">" : "="; if (ord0->tag == PL_TERM_ATOM) { if (!strcmp(ord0->v.atom_name, sym)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } pl_term *ord = make_atom_rt(rt_ctrl, dbg_dat_ptr, sym); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], ord, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (((!strcmp(fn, "@<") || !strcmp(fn, "@=<") || !strcmp(fn, "@>") || !strcmp(fn, "@>=")) && (ar == 2))) { pl_var_stack st; var_stack_init(&st); const int r = compare_std_terms(goal->v.str.args[0], goal->v.str.args[1], env_in, &st, dbg_dat_ptr, 0); var_stack_free(&st); bool ok = false; if (!strcmp(fn, "@<")) { ok = (r < 0); } else if (!strcmp(fn, "@=<")) { ok = (r <= 0); } else if (!strcmp(fn, "@>")) { ok = (r > 0); } else if (!strcmp(fn, "@>=")) { ok = (r >= 0); } if (ok) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "is") && (ar == 2)) { pl_number val = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex(goal->v.str.args[1], env_in, &val, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", "is", 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", "is", 2); } pl_term *rhs = num_to_term_rt(val, rt_ctrl, dbg_dat_ptr); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal->v.str.args[0], rhs, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals(prog, q, goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (((!strcmp(fn, "=:=") || !strcmp(fn, "=\\=") || !strcmp(fn, "<") || !strcmp(fn, "=<") || !strcmp(fn, ">") || !strcmp(fn, ">=")) && (ar == 2))) { pl_number a = {0}, b = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex(goal->v.str.args[0], env_in, &a, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[0], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[0], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", fn, 2); } memset(&aerr, 0, sizeof(aerr)); if (!eval_num_expr_ex(goal->v.str.args[1], env_in, &b, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal->v.str.args[1], env_in); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, fn, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", fn, 2); } bool ok = false; if (!num_is_float(a) && !num_is_float(b)) { const int cmp = num_cmp(a, b); if (!strcmp(fn, "=:=")) { ok = (cmp == 0); } else if (!strcmp(fn, "=\\=")) { ok = (cmp != 0); } else if (!strcmp(fn, "<")) { ok = (cmp < 0); } else if (!strcmp(fn, "=<")) { ok = (cmp <= 0); } else if (!strcmp(fn, ">")) { ok = (cmp > 0); } else if (!strcmp(fn, ">=")) { ok = (cmp >= 0); } } else { const double da = num_as_double(a); const double db = num_as_double(b); if (!strcmp(fn, "=:=")) { ok = (da == db); } else if (!strcmp(fn, "=\\=")) { ok = (da != db); } else if (!strcmp(fn, "<")) { ok = (da < db); } else if (!strcmp(fn, "=<")) { ok = (da <= db); } else if (!strcmp(fn, ">")) { ok = (da > db); } else if (!strcmp(fn, ">=")) { ok = (da >= db); } } if (ok) { return solve_goals(prog, q, goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } return cut_none(); } } // Flowlog extension: call-by-variant tabling for predicates declared via `:- table/1`. if (prog && g_table_state && goal && ((goal->tag == PL_TERM_ATOM) || (goal->tag == PL_TERM_STRUCT))) { const CHR *pred_name = NULL; ULO pred_arity = 0; if (goal->tag == PL_TERM_ATOM) { pred_name = goal->v.atom_name; pred_arity = 0; } else { pred_name = goal->v.str.functor; pred_arity = goal->v.str.arity; } if (pred_name && !builtin_pred_defined(pred_name, pred_arity) && prog_tabled_pred_contains(prog, pred_name, pred_arity)) { return table_call(prog, q, goal, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, on_solution, on_solution_ctx, rt_ctrl, dbg_dat_ptr); } } // ISO-ish unknown procedure handling (prolog_flag unknown). if (prog && goal && ((goal->tag == PL_TERM_ATOM) || (goal->tag == PL_TERM_STRUCT))) { const CHR *pred_name = NULL; ULO pred_arity = 0; if (goal->tag == PL_TERM_ATOM) { pred_name = goal->v.atom_name; pred_arity = 0; } else { pred_name = goal->v.str.functor; pred_arity = goal->v.str.arity; } bool dyn = false; if (pred_name && !prog_pred_defined(prog, pred_name, pred_arity, &dyn)) { if (prog->flag_unknown == PL_UNKNOWN_FAIL) { if (prog->flag_trace) { trace_emit_prolog_term('!', depth, "FAIL", goal, env_in, NULL); } return cut_none(); } if (prog->flag_unknown == PL_UNKNOWN_WARNING) { streams_init(dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(2, &s, dbg_dat_ptr) || !s || !s->writable) { (void)fprintf(stderr, "Warning: unknown procedure: %s/%lu\n", pred_name, (unsigned long)pred_arity); } else { (void)fprintf(s->fp, "Warning: unknown procedure: %s/%lu\n", pred_name, (unsigned long)pred_arity); (void)fflush(s->fp); } if (prog->flag_trace) { trace_emit_prolog_term('!', depth, "FAIL", goal, env_in, NULL); } return cut_none(); } pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "procedure", pi, env_in, pred_name, pred_arity); } } // If no clauses were built (facts-only program), fall back to the facts table. if (!prog->clause_count || !prog->clauses) { int pred_barrier = 0; const SLO outer_barrier_value = (SLO)(uintptr_t)cut_barrier; pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, outer_barrier_value); pl_term *drop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop->reserved16 = (uint16_t)(depth + 1u); drop->v.str.args[0] = outer_barrier_term; const bool orpar_alt_ok = (prog->fact_count >= FLOWLOG_ORPAR_MIN_ALT_THRESHOLD); const bool orpar_depth_ok = ((SLO)depth < prog->flag_parallel_max_depth) || (prog->fact_count >= FLOWLOG_ORPAR_BIG_ALT_THRESHOLD); const bool par_or = prog && g_par_state && (g_table_state == NULL) && ((SLO)g_orpar_level <= prog->flag_parallel_or_nesting) && prog->flag_parallel_or && (prog->flag_parallel_max_depth > 0) && orpar_alt_ok && orpar_depth_ok && !stop_at_first && ((on_solution == NULL) || (prog->flag_parallel_or_order == PL_OR_UNORDERED)) && (prog->fact_count > 1); if (par_or) { const uint64_t orpar_t0 = flowlog_monotonic_ns(); const ULO alt_count = prog->fact_count; ULO worker_count = orpar_worker_count_for_alts(alt_count, (ULO)g_par_state->max_threads); int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } if (worker_count < 2) { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } else { ULO chunk_count = worker_count * 128; const ULO chunk_cap = 16384; if (chunk_count > chunk_cap) { chunk_count = chunk_cap; } if (chunk_count > alt_count) { chunk_count = alt_count; } if (!chunk_count) { chunk_count = alt_count; } const CHR *pred = NULL; ULO pred_arity = 0; if (goal && goal->tag == PL_TERM_ATOM) { pred = goal->v.atom_name; pred_arity = 0; } else if (goal && goal->tag == PL_TERM_STRUCT) { pred = goal->v.str.functor; pred_arity = goal->v.str.arity; } flowlog_debug_orpar_log_start(pred, pred_arity, alt_count, worker_count, chunk_count, depth, stop_at_first); pl_or_job *workers = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*workers) * worker_count, dbg_dat_ptr); memset(workers, 0, sizeof(*workers) * worker_count); pl_or_job *chunks = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*chunks) * chunk_count, dbg_dat_ptr); memset(chunks, 0, sizeof(*chunks) * chunk_count); pl_or_work *work = (pl_or_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->count = worker_count; work->jobs = workers; work->chunk_count = chunk_count; work->chunks = chunks; work->unordered = (prog->flag_parallel_or_order == PL_OR_UNORDERED); atomic_init(&work->next_chunk, 0); atomic_init(&work->commit_chunk, 0); atomic_init(&work->max_chunk, (unsigned long)(chunk_count ? (chunk_count - 1) : 0)); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; atomic_init(&work->budget_returned, 0); work->budget_total = remote_taken; work->dbg_t0_ns = orpar_t0; atomic_init(&work->dbg_first_cut_chunk, (unsigned long)ULONG_MAX); for (ULO i = 0; i < chunk_count; i++) { const ULO start = (ULO)(((unsigned __int128)i * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); ULO end = (ULO)(((unsigned __int128)(i + 1) * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); if (end > alt_count) { end = alt_count; } chunks[i] = (pl_or_job){ .kind = ((end - start) == 1) ? PL_OR_JOB_FACT : PL_OR_JOB_FACT_RANGE, .prog = prog, .q = q, .goal = goal, .env_in = env_in, .drop = drop, .rest_goals = (pl_term *const *)(goals + 1), .rest_count = goal_count ? (goal_count - 1) : 0, .cut_barrier = &pred_barrier, .exc_barrier = exc_barrier, .depth = depth, .stop_at_first = stop_at_first, .capture_solution_output = (out != NULL) || (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .capture_solution_spans = (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .on_solution = on_solution, .on_solution_ctx = on_solution_ctx, .on_solution_safe_temp_release = g_on_solution_safe_temp_release, .local_alloc_ok = true, .stringify_exceptions = false, .chunk_index = i, .work_done = NULL, // chunk completion is tracked via job->done .work_cancel = &work->cancel, }; atomic_init(&chunks[i].done, 0); if ((end - start) == 1) { chunks[i].u.fact = (const pl_term *)prog->facts[start + 1]; } else { chunks[i].u.fact_range.facts = (const pl_term **)prog->facts; chunks[i].u.fact_range.start = start; chunks[i].u.fact_range.end = end; } } for (ULO i = 0; i < worker_count; i++) { workers[i] = (pl_or_job){ .kind = PL_OR_JOB_WORKER, .prog = prog, .work_done = &work->done, .work_cancel = &work->cancel, }; workers[i].u.worker.work = work; workers[i].budget_return = (i == 0) ? 0 : 1; atomic_init(&workers[i].done, 0); } pl_cut_signal ret = cut_none(); bool stopped = false; const ULO started = flowlog_start_or_work(work, 2, rt_ctrl, dbg_dat_ptr); if (g_par_budget && remote_taken && ((int)started < remote_taken)) { par_global_budget_give(g_par_budget, remote_taken - (int)started); remote_taken = (int)started; work->budget_total = remote_taken; } if (!work->unordered) { ULO last_done = 0; for (ULO i = 0; i < chunk_count; i++) { atomic_store(&work->commit_chunk, (unsigned long)i); pl_or_job *j = &chunks[i]; while (!atomic_load(&j->done)) { if (flowlog_cancelled()) { break; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { if (j->sig.target == &pred_barrier) { ret = cut_none(); } else { ret = j->sig; } stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); last_done = i + 1; if (stopped) { break; } } // Ensure workers have stopped before cleaning up remaining chunk outputs. if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); if (stopped && (last_done < chunk_count)) { for (ULO i = last_done; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } } else { ULO done_count = 0; ULO scan = 0; while (done_count < chunk_count) { if (flowlog_cancelled()) { break; } bool progressed = false; for (ULO n = 0; n < chunk_count; n++) { const ULO idx = (scan + n) % chunk_count; pl_or_job *j = &chunks[idx]; const int done = atomic_load(&j->done); if (done != 1) { continue; } done_count++; scan = idx + 1; progressed = true; pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { if (j->sig.target == &pred_barrier) { ret = cut_none(); } else { ret = j->sig; } stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); atomic_store(&j->done, 2); if (stopped) { break; } } if (stopped) { break; } if (progressed) { continue; } if (atomic_load_explicit(&work->cancel, memory_order_relaxed)) { usleep(1000); continue; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } // Ensure workers have stopped before cleaning up any remaining chunk outputs. if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); for (ULO i = 0; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } flowlog_debug_orpar_log_stop(pred, pred_arity, alt_count, flowlog_monotonic_ns() - orpar_t0, stopped, atomic_load(&work->cancel) != 0); if (!ret.cut && !ret.except && prog && prog->flag_trace) { trace_emit_prolog_term('!', depth, "FAIL", goal, env_in, NULL); } return ret; } } for (ULO i = 1; i <= prog->fact_count; i++) { const bool release_temp = g_temp_alloc && ((on_solution == NULL) || g_on_solution_safe_temp_release); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal, prog->facts[i], env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } const ULO rest = goal_count - 1; const ULO new_goal_count = 1 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = drop; for (ULO j = 1; j < goal_count; j++) { new_goals[j] = goals[j]; } pl_cut_signal r = solve_goals(prog, q, new_goals, new_goal_count, env1, &pred_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); if (r.except) { return r; } if (!r.cut) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } if (r.target == &pred_barrier) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return r; } if (prog && prog->flag_trace) { trace_emit_prolog_term('!', depth, "FAIL", goal, env_in, NULL); } return cut_none(); } int pred_barrier = 0; const SLO outer_barrier_value = (SLO)(uintptr_t)cut_barrier; pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, outer_barrier_value); pl_term *drop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop->reserved16 = (uint16_t)(depth + 1u); drop->v.str.args[0] = outer_barrier_term; const CHR *goal_name = NULL; ULO goal_arity = 0; if (goal && goal->tag == PL_TERM_ATOM) { goal_name = goal->v.atom_name; goal_arity = 0; } else if (goal && goal->tag == PL_TERM_STRUCT) { goal_name = goal->v.str.functor; goal_arity = goal->v.str.arity; } // Snapshot the clause list for this predicate call (logical update view). // This avoids re-visiting clauses when the database is modified (asserta/1, retract/1, ...) while iterating, and also // avoids cloning/unifying heads for unrelated predicates. const pl_clause **cands = NULL; ULO cand_count = 0; if (goal_name && prog->clause_count && prog->clauses) { cands = prog_snapshot_pred_cands(prog, goal_name, goal_arity, goal, env_in, &cand_count, rt_ctrl, dbg_dat_ptr); // Fallback: no index available (should be rare). if (!cands && prog->clause_count) { cands = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(*cands) * prog->clause_count, dbg_dat_ptr); for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *hn = NULL; ULO ha = 0; if (h->tag == PL_TERM_ATOM) { hn = h->v.atom_name; ha = 0; } else if (h->tag == PL_TERM_STRUCT) { hn = h->v.str.functor; ha = h->v.str.arity; } else { continue; } if (hn && (ha == goal_arity) && !strcmp(hn, goal_name)) { cands[cand_count++] = cl; } } } } const bool orpar_alt_ok = (cand_count >= FLOWLOG_ORPAR_MIN_ALT_THRESHOLD); const bool orpar_depth_ok = ((SLO)depth < prog->flag_parallel_max_depth) || (cand_count >= FLOWLOG_ORPAR_BIG_ALT_THRESHOLD); const bool par_or = prog && g_par_state && (g_table_state == NULL) && ((SLO)g_orpar_level <= prog->flag_parallel_or_nesting) && prog->flag_parallel_or && (prog->flag_parallel_max_depth > 0) && orpar_alt_ok && orpar_depth_ok && !stop_at_first && ((on_solution == NULL) || (prog->flag_parallel_or_order == PL_OR_UNORDERED)) && (cand_count > 1); if (par_or) { const uint64_t orpar_t0 = flowlog_monotonic_ns(); const ULO alt_count = cand_count; ULO worker_count = orpar_worker_count_for_alts(alt_count, (ULO)g_par_state->max_threads); int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } if (worker_count < 2) { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } else { ULO chunk_count = worker_count * 128; const ULO chunk_cap = 16384; if (chunk_count > chunk_cap) { chunk_count = chunk_cap; } if (chunk_count > alt_count) { chunk_count = alt_count; } if (!chunk_count) { chunk_count = alt_count; } flowlog_debug_orpar_log_start(goal_name, goal_arity, alt_count, worker_count, chunk_count, depth, stop_at_first); pl_or_job *workers = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*workers) * worker_count, dbg_dat_ptr); memset(workers, 0, sizeof(*workers) * worker_count); pl_or_job *chunks = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*chunks) * chunk_count, dbg_dat_ptr); memset(chunks, 0, sizeof(*chunks) * chunk_count); pl_or_work *work = (pl_or_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->count = worker_count; work->jobs = workers; work->chunk_count = chunk_count; work->chunks = chunks; work->unordered = (prog->flag_parallel_or_order == PL_OR_UNORDERED); atomic_init(&work->next_chunk, 0); atomic_init(&work->commit_chunk, 0); atomic_init(&work->max_chunk, (unsigned long)(chunk_count ? (chunk_count - 1) : 0)); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; atomic_init(&work->budget_returned, 0); work->budget_total = remote_taken; work->dbg_t0_ns = orpar_t0; atomic_init(&work->dbg_first_cut_chunk, (unsigned long)ULONG_MAX); for (ULO i = 0; i < chunk_count; i++) { const ULO start = (ULO)(((unsigned __int128)i * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); ULO end = (ULO)(((unsigned __int128)(i + 1) * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); if (end > alt_count) { end = alt_count; } chunks[i] = (pl_or_job){ .kind = ((end - start) == 1) ? PL_OR_JOB_CLAUSE : PL_OR_JOB_CLAUSE_RANGE, .prog = prog, .q = q, .goal = goal, .env_in = env_in, .drop = drop, .rest_goals = (pl_term *const *)(goals + 1), .rest_count = goal_count ? (goal_count - 1) : 0, .cut_barrier = &pred_barrier, .exc_barrier = exc_barrier, .depth = depth, .stop_at_first = stop_at_first, .capture_solution_output = (out != NULL) || (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .capture_solution_spans = (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .on_solution = on_solution, .on_solution_ctx = on_solution_ctx, .on_solution_safe_temp_release = g_on_solution_safe_temp_release, .local_alloc_ok = true, .stringify_exceptions = false, .chunk_index = i, .work_done = NULL, .work_cancel = &work->cancel, }; atomic_init(&chunks[i].done, 0); if ((end - start) == 1) { chunks[i].u.cl = cands[start]; } else { chunks[i].u.clause_range.cands = cands; chunks[i].u.clause_range.start = start; chunks[i].u.clause_range.end = end; } } for (ULO i = 0; i < worker_count; i++) { workers[i] = (pl_or_job){ .kind = PL_OR_JOB_WORKER, .prog = prog, .work_done = &work->done, .work_cancel = &work->cancel, }; workers[i].u.worker.work = work; workers[i].budget_return = (i == 0) ? 0 : 1; atomic_init(&workers[i].done, 0); } pl_cut_signal ret = cut_none(); bool stopped = false; const ULO started = flowlog_start_or_work(work, 2, rt_ctrl, dbg_dat_ptr); if (g_par_budget && remote_taken && ((int)started < remote_taken)) { par_global_budget_give(g_par_budget, remote_taken - (int)started); remote_taken = (int)started; work->budget_total = remote_taken; } if (!work->unordered) { ULO last_done = 0; for (ULO i = 0; i < chunk_count; i++) { atomic_store(&work->commit_chunk, (unsigned long)i); pl_or_job *j = &chunks[i]; while (!atomic_load(&j->done)) { if (flowlog_cancelled()) { break; } // Help progress the work while waiting for ordered chunk i to complete. unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { if (j->sig.target == &pred_barrier) { ret = cut_none(); } else { ret = j->sig; } stopped = true; atomic_store(&work->cancel, 1); if (flowlog_debug_orpar_level() > 0) { uint64_t dt_ns = 0; if (work->dbg_t0_ns) { const uint64_t now = flowlog_monotonic_ns(); if (now >= work->dbg_t0_ns) { dt_ns = now - work->dbg_t0_ns; } } const double ms = dt_ns ? ((double)dt_ns / 1000000.0) : 0.0; const unsigned long first_cut = atomic_load_explicit(&work->dbg_first_cut_chunk, memory_order_acquire); if (first_cut == (unsigned long)ULONG_MAX) { flowlog_debug_orpar_printf("flowlog: ORPAR commit %s/%lu chunk=%lu dt_ms=%.3f first_cut=none target=%p\n", goal_name ? goal_name : "?", (unsigned long)goal_arity, (unsigned long)i, ms, j->sig.target); } else { flowlog_debug_orpar_printf("flowlog: ORPAR commit %s/%lu chunk=%lu dt_ms=%.3f first_cut=%lu target=%p\n", goal_name ? goal_name : "?", (unsigned long)goal_arity, (unsigned long)i, ms, first_cut, j->sig.target); } } } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); last_done = i + 1; if (stopped) { break; } } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); if (stopped && (last_done < chunk_count)) { for (ULO i = last_done; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } } else { ULO done_count = 0; ULO scan = 0; while (done_count < chunk_count) { if (flowlog_cancelled()) { break; } bool progressed = false; for (ULO n = 0; n < chunk_count; n++) { const ULO idx = (scan + n) % chunk_count; pl_or_job *j = &chunks[idx]; const int done = atomic_load(&j->done); if (done != 1) { continue; } done_count++; scan = idx + 1; progressed = true; pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { if (j->sig.target == &pred_barrier) { ret = cut_none(); } else { ret = j->sig; } stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); atomic_store(&j->done, 2); if (stopped) { break; } } if (stopped) { break; } if (progressed) { continue; } if (atomic_load_explicit(&work->cancel, memory_order_relaxed)) { usleep(1000); continue; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); for (ULO i = 0; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } flowlog_debug_orpar_log_stop(goal_name, goal_arity, alt_count, flowlog_monotonic_ns() - orpar_t0, stopped, atomic_load(&work->cancel) != 0); if (!ret.cut && !ret.except && prog && prog->flag_trace) { trace_emit_prolog_term('!', depth, "FAIL", goal, env_in, NULL); } return ret; } } for (ULO ci = 0; ci < cand_count; ci++) { const pl_clause *cl = cands[ci]; if (!cl || !cl->head) { continue; } const bool release_temp = g_temp_alloc && ((on_solution == NULL) || g_on_solution_safe_temp_release); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } // Standardize-apart by cloning with a fresh scope. pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); env1->intro_scope = scope; env_apply_clause_bindings_arena(cl, scope, env1, &arena, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal, head, env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } const ULO new_goal_count = cl->body_count + 1 + (goal_count - 1); pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } ULO pos = 0; for (ULO j = 1; j <= cl->body_count; j++) { new_goals[pos++] = clone_term_with_scope_arena(cl->body[j], cl->scope, scope, &arena, dbg_dat_ptr, 0); } new_goals[pos++] = drop; for (ULO j = 1; j < goal_count; j++) { new_goals[pos++] = goals[j]; } const pl_clause *saved_clause = g_trace_clause; const pl_clause *saved_argv_clause = flowlog_argv_clause_push(cl); g_trace_clause = cl; pl_cut_signal r = solve_goals(prog, q, new_goals, new_goal_count, env1, &pred_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); flowlog_argv_clause_pop(saved_argv_clause); g_trace_clause = saved_clause; if (r.except) { return r; } if (!r.cut) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } if (r.target == &pred_barrier) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return cut_none(); } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return r; } return cut_none(); } #undef solve_goals static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_read(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal || !goals || !goal_count) { return cut_none(); } streams_init(dbg_dat_ptr); const ULO ar = goal->v.str.arity; SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "read", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "read", 2); } return cut_none(); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "read", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "read", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "read", ar); } if (!solution_stream_wait_for_input(s)) { return cut_none(); } stream_flush_prompt_output_before_read(s, rt_ctrl, dbg_dat_ptr); const ULO term_base_line = s->line_count ? s->line_count : 1; const ULO term_base_col = s->line_pos ? s->line_pos : 1; const char *term_src_name = (s->file_name && s->file_name[0]) ? s->file_name : ((s->alias && s->alias[0]) ? s->alias : ""); pl_sbuf src; sbuf_init(&src, rt_ctrl, dbg_dat_ptr); const bool char_conv_on = prog ? prog->flag_char_conversion : false; const unsigned char *char_conv_table = prog ? prog->char_conv_table : NULL; const bool character_escapes = prog ? prog->flag_character_escapes : true; bool is_eof = false; const CHR *syntax_error_reason = NULL; const CHR *syntax_error_pos = NULL; if (!stream_read_term_src( s, &src, &is_eof, char_conv_on, char_conv_table, character_escapes, dbg_dat_ptr, &syntax_error_reason, &syntax_error_pos)) { if (syntax_error_reason) { report_stream_syntax_error(term_src_name, term_base_line, term_base_col, src.buf, syntax_error_pos, syntax_error_reason); } sbuf_free(&src); if (syntax_error_reason) { return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, syntax_error_reason, "read", ar); } return cut_none(); } pl_term *read_term_val = NULL; if (is_eof) { read_term_val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { pl_parse p = {0}; p.src_name = term_src_name; p.src_base_line = term_base_line; p.src_base_col = term_base_col; p.rt_ctrl = rt_ctrl; p.dbg_dat_ptr = dbg_dat_ptr; p.ops = prog ? prog->op_overrides : NULL; p.double_quotes = prog ? prog->flag_double_quotes : PL_DQ_CHARS; p.character_escapes = character_escapes; lex_init(&p.lx, src.buf ? src.buf : "", char_conv_on, char_conv_table, character_escapes); pl_var_table vt = {0}; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); read_term_val = parse_term(&p, &vt, scope, true, 1200); if (peek_tok(&p).type == TOK_DOT) { (void)take_tok(&p); } else { expect_tok(&p, TOK_DOT); } if (peek_tok(&p).type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected trailing tokens after read/1", dbg_dat_ptr); } } sbuf_free(&src); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(term_arg, read_term_val, env1, rt_ctrl, dbg_dat_ptr)) { return solve_goals_tls(goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count); } return cut_none(); } static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_read_term(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal || !goals || !goal_count) { return cut_none(); } streams_init(dbg_dat_ptr); const ULO ar = goal->v.str.arity; SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; pl_term *opts_arg = goal->v.str.args[1]; if (ar == 3) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "read_term", 3); } term_arg = goal->v.str.args[1]; opts_arg = goal->v.str.args[2]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 3) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "read_term", 3); } return cut_none(); } if (!s->readable) { if (ar == 3) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, env_in, "read_term", 3); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, env_in, "read_term", 2); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, env_in, "read_term", ar); } if (!solution_stream_wait_for_input(s)) { return cut_none(); } pl_term *opts_term = deref_term(opts_arg, env_in); if (!opts_term) { return cut_none(); } if (opts_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } if (!term_is_list_pair(opts_term) && !term_is_nil(opts_term)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", opts_term, env_in, "read_term", ar); } pl_term *vars_target = NULL; pl_term *varnames_target = NULL; pl_term *singletons_target = NULL; bool character_escapes = prog ? prog->flag_character_escapes : true; pl_double_quotes_mode dq_mode = prog ? prog->flag_double_quotes : PL_DQ_CHARS; pl_term *opt_cur = opts_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, opt_cur); while (1) { opt_cur = deref_term(opt_cur, env_in); if (term_is_nil(opt_cur)) { break; } if (opt_cur->tag == PL_TERM_VAR) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, "read_term", ar); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } if (!term_is_list_pair(opt_cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", opts_term, env_in, "read_term", ar); } pl_term *opt = deref_term(opt_cur->v.str.args[0], env_in); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, "read_term", ar); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "variables")) { vars_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "variable_names")) { varnames_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "singletons")) { singletons_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "character_escapes")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, env_in, "read_term", ar); } character_escapes = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "double_quotes")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, env_in, "read_term", ar); } if (!strcmp(v->v.atom_name, "atom")) { dq_mode = PL_DQ_ATOM; } else if (!strcmp(v->v.atom_name, "codes")) { dq_mode = PL_DQ_CODES; } else if (!strcmp(v->v.atom_name, "chars")) { dq_mode = PL_DQ_CHARS; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, env_in, "read_term", ar); } } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, env_in, "read_term", ar); } opt_cur = opt_cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, env_in)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "read_term", ar); } } stream_flush_prompt_output_before_read(s, rt_ctrl, dbg_dat_ptr); const ULO term_base_line = s->line_count ? s->line_count : 1; const ULO term_base_col = s->line_pos ? s->line_pos : 1; const char *term_src_name = (s->file_name && s->file_name[0]) ? s->file_name : ((s->alias && s->alias[0]) ? s->alias : ""); pl_sbuf src; sbuf_init(&src, rt_ctrl, dbg_dat_ptr); const bool char_conv_on = prog ? prog->flag_char_conversion : false; const unsigned char *char_conv_table = prog ? prog->char_conv_table : NULL; bool is_eof = false; const CHR *syntax_error_reason = NULL; const CHR *syntax_error_pos = NULL; if (!stream_read_term_src( s, &src, &is_eof, char_conv_on, char_conv_table, character_escapes, dbg_dat_ptr, &syntax_error_reason, &syntax_error_pos)) { if (syntax_error_reason) { report_stream_syntax_error(term_src_name, term_base_line, term_base_col, src.buf, syntax_error_pos, syntax_error_reason); } sbuf_free(&src); if (syntax_error_reason) { return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, syntax_error_reason, "read_term", ar); } return cut_none(); } pl_term *read_term_val = NULL; pl_var_list vars_list = {0}; pl_var_list named_list = {0}; pl_var_list singletons_list = {0}; if (is_eof) { read_term_val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { pl_parse p = {0}; p.src_name = term_src_name; p.src_base_line = term_base_line; p.src_base_col = term_base_col; p.rt_ctrl = rt_ctrl; p.dbg_dat_ptr = dbg_dat_ptr; p.ops = prog ? prog->op_overrides : NULL; p.double_quotes = dq_mode; p.character_escapes = character_escapes; lex_init(&p.lx, src.buf ? src.buf : "", char_conv_on, char_conv_table, character_escapes); pl_var_table vt = {0}; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); read_term_val = parse_term(&p, &vt, scope, true, 1200); expect_tok(&p, TOK_DOT); if (peek_tok(&p).type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected trailing tokens after read_term/*", dbg_dat_ptr); } if (vars_target || varnames_target || singletons_target) { pl_var_stack st; var_stack_init(&st); var_list_init(&vars_list); term_collect_vars_tr(read_term_val, env_in, &st, &vars_list, dbg_dat_ptr, 0); var_stack_free(&st); if (varnames_target || singletons_target) { // Build a named var list in first-appearance order, skipping anonymous '_'. var_list_init(&named_list); var_list_init(&singletons_list); pl_var_count_list counts; var_count_list_init(&counts); pl_var_stack st2; var_stack_init(&st2); term_count_vars_tr(read_term_val, env_in, &st2, &counts, dbg_dat_ptr, 0); var_stack_free(&st2); for (ULO i = 0; i < counts.count; i++) { pl_term *v = counts.items[i].term; if (!v || v->tag != PL_TERM_VAR) { continue; } const CHR *nm = v->v.var.var_name; if (!nm || (nm[0] == '_' && nm[1] == '\0')) { continue; // anonymous '_' } var_list_add_unique(&named_list, dbg_dat_ptr, counts.items[i].key, v); if (counts.items[i].count == 1) { var_list_add_unique(&singletons_list, dbg_dat_ptr, counts.items[i].key, v); } } var_count_list_free(&counts); } } } sbuf_free(&src); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(term_arg, read_term_val, env1, rt_ctrl, dbg_dat_ptr)) { var_list_free(&vars_list); var_list_free(&named_list); var_list_free(&singletons_list); return cut_none(); } if (vars_target) { pl_term *list = NULL; if (!vars_list.count) { list = make_atom_rt(rt_ctrl, dbg_dat_ptr, "[]"); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * vars_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < vars_list.count; i++) { elems[i] = vars_list.items[i].term; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, vars_list.count); free(elems); } if (!unify_terms(vars_target, list, env1, rt_ctrl, dbg_dat_ptr)) { var_list_free(&vars_list); var_list_free(&named_list); var_list_free(&singletons_list); return cut_none(); } } if (varnames_target) { pl_term *list = NULL; if (!named_list.count) { list = make_atom_rt(rt_ctrl, dbg_dat_ptr, "[]"); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * named_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < named_list.count; i++) { pl_term *v = named_list.items[i].term; pl_term *pair = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); pair->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, v->v.var.var_name ? v->v.var.var_name : ""); pair->v.str.args[1] = v; elems[i] = pair; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, named_list.count); free(elems); } if (!unify_terms(varnames_target, list, env1, rt_ctrl, dbg_dat_ptr)) { var_list_free(&vars_list); var_list_free(&named_list); var_list_free(&singletons_list); return cut_none(); } } if (singletons_target) { pl_term *list = NULL; if (!singletons_list.count) { list = make_atom_rt(rt_ctrl, dbg_dat_ptr, "[]"); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * singletons_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < singletons_list.count; i++) { pl_term *v = singletons_list.items[i].term; pl_term *pair = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); pair->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, v->v.var.var_name ? v->v.var.var_name : ""); pair->v.str.args[1] = v; elems[i] = pair; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, singletons_list.count); free(elems); } if (!unify_terms(singletons_target, list, env1, rt_ctrl, dbg_dat_ptr)) { var_list_free(&vars_list); var_list_free(&named_list); var_list_free(&singletons_list); return cut_none(); } } var_list_free(&vars_list); var_list_free(&named_list); var_list_free(&singletons_list); return solve_goals_tls(goals + 1, goal_count - 1, env1, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count); } static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_write(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal || !goals || !goal_count) { return cut_none(); } streams_init(dbg_dat_ptr); const ULO ar = goal->v.str.arity; SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "write", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "write", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "write", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "write", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "write", ar); } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = false, .ignore_ops = false, .numbervars = true}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, env_in, &wopts, &sb, dbg_dat_ptr); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); return solve_goals_tls(goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count); } static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_writeq(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal || !goals || !goal_count) { return cut_none(); } streams_init(dbg_dat_ptr); const ULO ar = goal->v.str.arity; SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "writeq", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "writeq", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "writeq", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "writeq", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "writeq", ar); } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false, .numbervars = true}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, env_in, &wopts, &sb, dbg_dat_ptr); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); return solve_goals_tls(goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count); } static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_write_canonical(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal || !goals || !goal_count) { return cut_none(); } streams_init(dbg_dat_ptr); const ULO ar = goal->v.str.arity; SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "write_canonical", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "write_canonical", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "write_canonical", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "write_canonical", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "write_canonical", ar); } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = true}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, env_in, &wopts, &sb, dbg_dat_ptr); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); return solve_goals_tls(goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count); } static FLOWLOG_NOINLINE pl_cut_signal solve_goals_builtin_write_term(pl_program *prog, pl_term *goal, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!goal || !goals || !goal_count) { return cut_none(); } streams_init(dbg_dat_ptr); const ULO ar = goal->v.str.arity; SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; pl_term *opts_arg = goal->v.str.args[1]; if (ar == 3) { st_term = deref_term(goal->v.str.args[0], env_in); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id(goal->v.str.args[0], env_in, dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "write_term", 3); } term_arg = goal->v.str.args[1]; opts_arg = goal->v.str.args[2]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 3) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, env_in, "write_term", 3); } return cut_none(); } if (!s->writable) { if (ar == 3) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, env_in, "write_term", 3); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, env_in, "write_term", 2); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, env_in, "write_term", ar); } pl_write_opts wopts = {.quoted = false, .ignore_ops = false}; pl_term *opts_term = deref_term(opts_arg, env_in); if (!opts_term) { return cut_none(); } if (opts_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } pl_write_var_name_map vnames; write_var_name_map_init(&vnames); bool have_var_names = false; pl_term *cur = opts_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term(cur, env_in); if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { // Trealla reports the predicate indicator for partial option lists. write_var_name_map_free(&vnames); pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, "write_term", ar); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } if (!term_is_list_pair(cur)) { write_var_name_map_free(&vnames); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", opts_term, env_in, "write_term", ar); } pl_term *opt = deref_term(cur->v.str.args[0], env_in); if (!opt) { write_var_name_map_free(&vnames); return cut_none(); } if (opt->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "quoted")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } wopts.quoted = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "ignore_ops")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } wopts.ignore_ops = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "numbervars")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } wopts.numbervars = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "fullstop")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } wopts.fullstop = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "nl")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } wopts.nl = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "max_depth")) { pl_term *v = deref_term(opt->v.str.args[0], env_in); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_INT || v->v.int_value < 0) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } wopts.max_depth = (ULO)v->v.int_value; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "variable_names")) { pl_term *list = deref_term(opt->v.str.args[0], env_in); if (!list) { write_var_name_map_free(&vnames); return cut_none(); } if (list->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (!term_is_nil(list) && !term_is_list_pair(list)) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } have_var_names = true; pl_term *lc = list; pl_list_cycle_guard cg2; list_cycle_guard_init(&cg2, lc); while (1) { lc = deref_term(lc, env_in); if (!lc) { write_var_name_map_free(&vnames); return cut_none(); } if (term_is_nil(lc)) { break; } if (lc->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (!term_is_list_pair(lc)) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } pl_term *pair = deref_term(lc->v.str.args[0], env_in); if (!pair) { write_var_name_map_free(&vnames); return cut_none(); } if (pair->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (pair->tag != PL_TERM_STRUCT || pair->v.str.arity != 2 || strcmp(pair->v.str.functor, "=")) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } pl_term *nm = deref_term(pair->v.str.args[0], env_in); if (!nm) { write_var_name_map_free(&vnames); return cut_none(); } if (nm->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (nm->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } pl_term *var = deref_term(pair->v.str.args[1], env_in); if (!var) { write_var_name_map_free(&vnames); return cut_none(); } if (var->tag != PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } pl_var_key k = {.scope = var->v.var.scope, .var_id = var->v.var.var_id}; write_var_name_add_unique(&vnames, dbg_dat_ptr, k, nm->v.atom_name); lc = lc->v.str.args[1]; if (list_cycle_guard_step_tr(&cg2, env_in)) { write_var_name_map_free(&vnames); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "write_term", ar); } } } else { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, env_in, "write_term", ar); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, env_in)) { write_var_name_map_free(&vnames); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "write_term", ar); } } wopts.var_names = have_var_names ? &vnames : NULL; pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, env_in, &wopts, &sb, dbg_dat_ptr); if (wopts.fullstop) { sbuf_append_char(&sb, '.'); } if (wopts.nl) { sbuf_append_char(&sb, '\n'); } if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); write_var_name_map_free(&vnames); return solve_goals_tls(goals + 1, goal_count - 1, env_in, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count); } static pl_cut_signal solve_goals_cb(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, pl_on_solution_fn on_solution, void *on_solution_ctx, const void *rt_ctrl, const ULO *dbg_dat_ptr) { const pl_solve_tls_state saved = g_solve_tls; g_solve_tls = (pl_solve_tls_state){ .prog = prog, .q = q, .on_solution = on_solution, .on_solution_ctx = on_solution_ctx, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, }; pl_cut_signal r = solve_goals_tls(goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count); g_solve_tls = saved; return r; } static pl_cut_signal solve_goals(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { return solve_goals_cb(prog, q, goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, NULL, NULL, rt_ctrl, dbg_dat_ptr); } static FLOWLOG_NOINLINE bool solve_goals_try_parallel_and(pl_cut_signal *out_sig, pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, const pl_env *env_in, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!out_sig) { return false; } *out_sig = cut_none(); if (!prog || !g_par_state || !prog->flag_parallel_and || (prog->flag_parallel_max_depth <= 0) || ((SLO)depth >= prog->flag_parallel_max_depth) || (goal_count < 2)) { return false; } // --- Speculative AND-parallelism --- // // Pre-dispatch later deterministic goals that are independent of the current // prefix (no shared free variables with any earlier goal), rewriting them to // $await_and/2 and awaiting them in classic left-to-right order. { // Avoid recursively re-speculating already rewritten goal lists. bool has_await = false; for (ULO i = 0; i < goal_count; i++) { pl_term *gi = deref_term(goals[i], env_in); if (gi && (gi->tag == PL_TERM_STRUCT) && gi->v.str.functor && (gi->v.str.arity == 2) && !strcmp(gi->v.str.functor, "$await_and")) { has_await = true; break; } } // If the first two goals are already eligible for the (cheaper) prefix // AND-par path, prefer that. bool prefer_prefix = false; if (!has_await) { pl_term *g0 = deref_term(goals[0], env_in); pl_term *g1 = deref_term(goals[1], env_in); if (g0 && g1 && par_and_goal_is_safe_test(prog, g0, env_in, rt_ctrl, dbg_dat_ptr) && par_and_goal_is_safe_test(prog, g1, env_in, rt_ctrl, dbg_dat_ptr) && par_goals_disjoint(g0, g1, env_in, dbg_dat_ptr)) { prefer_prefix = true; } } if (!has_await && !prefer_prefix) { ULO sel_idx[FLOWLOG_PAR_AND_MAX_BATCH]; ULO sel_count = 0; pl_var_stack st = {0}; pl_var_list prefix_vars; var_list_init(&prefix_vars); for (ULO i = 0; i < goal_count && sel_count < FLOWLOG_PAR_AND_MAX_BATCH; i++) { pl_term *gi = deref_term(goals[i], env_in); if (!gi) { continue; } if (par_and_goal_is_spec_barrier(gi)) { break; } pl_var_list vars_i; var_list_init(&vars_i); st.count = 0; term_collect_vars_tr(gi, env_in, &st, &vars_i, dbg_dat_ptr, 0); bool disj = true; for (ULO v = 0; v < vars_i.count; v++) { if (var_list_contains_key(&prefix_vars, vars_i.items[v].key)) { disj = false; break; } } // Only speculate goals that have at least one free variable: this // avoids wasting workers on trivial constant checks like `true` and // `1 < 2`. if ((i > 0) && vars_i.count && disj && par_and_goal_is_safe_test(prog, gi, env_in, rt_ctrl, dbg_dat_ptr)) { sel_idx[sel_count++] = i; } for (ULO v = 0; v < vars_i.count; v++) { var_list_add_unique(&prefix_vars, dbg_dat_ptr, vars_i.items[v].key, vars_i.items[v].term); } var_list_free(&vars_i); } var_stack_free(&st); var_list_free(&prefix_vars); if (sel_count) { int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)sel_count); sel_count = (ULO)remote_taken; } if (sel_count) { pl_and_job *jobs = (pl_and_job *)pool_alloc(rt_ctrl, sizeof(*jobs) * sel_count, dbg_dat_ptr); memset(jobs, 0, sizeof(*jobs) * sel_count); pl_and_work *work = (pl_and_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); *work = (pl_and_work){.count = sel_count, .jobs = jobs}; atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; for (ULO j = 0; j < sel_count; j++) { const ULO gi = sel_idx[j]; pl_term *goal_j = deref_term(goals[gi], env_in); jobs[j] = (pl_and_job){ .prog = prog, .q = q, .goal = goal_j, .env_in = env_in, .cut_barrier = cut_barrier, .exc_barrier = exc_barrier, .depth = depth + 1, .work_done = &work->done, .work_cancel = &work->cancel, .ok = false, .sig = cut_none(), .env_out = env_in, .tmp_snapshot = NULL, }; atomic_init(&jobs[j].done, 0); } const bool started = flowlog_start_and_work(work, 1, rt_ctrl, dbg_dat_ptr); if (!started && g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); remote_taken = 0; } if (started) { pl_term **new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * goal_count, dbg_dat_ptr); for (ULO i = 0; i < goal_count; i++) { ULO job_idx = 0; for (ULO j = 0; j < sel_count; j++) { if (sel_idx[j] == i) { job_idx = j + 1; // 1-based break; } } if (!job_idx) { new_goals[i] = goals[i]; continue; } pl_term *await = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$await_and", 2); await->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)work); await->v.str.args[1] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)job_idx); new_goals[i] = await; } *out_sig = solve_goals_tls(new_goals, goal_count, env_in, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count); atomic_store(&work->cancel, 1); flowlog_wait_done(&work->done, (int)sel_count); for (ULO j = 0; j < sel_count; j++) { pl_and_job_dispose(&jobs[j], rt_ctrl, dbg_dat_ptr); } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } return true; } } else { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } } } } // --- Conservative prefix AND-parallelism --- { pl_term *cand[FLOWLOG_PAR_AND_MAX_BATCH]; ULO cand_count = 0; for (ULO i = 0; i < goal_count && cand_count < FLOWLOG_PAR_AND_MAX_BATCH; i++) { pl_term *gi = deref_term(goals[i], env_in); if (!gi || !par_and_goal_is_safe_test(prog, gi, env_in, rt_ctrl, dbg_dat_ptr)) { break; } bool disj = true; for (ULO j = 0; j < cand_count; j++) { if (!par_goals_disjoint(cand[j], gi, env_in, dbg_dat_ptr)) { disj = false; break; } } if (!disj) { break; } cand[cand_count++] = gi; } if (cand_count >= 2) { ULO exec_count = cand_count; int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(exec_count - 1)); exec_count = (ULO)(1 + remote_taken); } if (exec_count >= 2) { pl_and_job *jobs = (pl_and_job *)pool_alloc(rt_ctrl, sizeof(*jobs) * exec_count, dbg_dat_ptr); memset(jobs, 0, sizeof(*jobs) * exec_count); pl_and_work *work = (pl_and_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); *work = (pl_and_work){.count = exec_count, .jobs = jobs}; atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; for (ULO i = 0; i < exec_count; i++) { jobs[i] = (pl_and_job){ .prog = prog, .q = q, .goal = cand[i], .env_in = env_in, .cut_barrier = cut_barrier, .exc_barrier = exc_barrier, .depth = depth + 1, .work_done = &work->done, .work_cancel = &work->cancel, .ok = false, .sig = cut_none(), .env_out = env_in, .tmp_snapshot = NULL, }; atomic_init(&jobs[i].done, 0); } bool started = flowlog_start_and_work(work, 2, rt_ctrl, dbg_dat_ptr); if (!started && g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); remote_taken = 0; } // Evaluate the leftmost goal locally so it can overlap with remote jobs. pl_and_job_run(&jobs[0], rt_ctrl, dbg_dat_ptr); if (!started) { for (ULO i = 1; i < exec_count; i++) { pl_and_job_run(&jobs[i], rt_ctrl, dbg_dat_ptr); } } pl_cut_signal early = cut_none(); bool stopped = false; ULO last_done = 0; const pl_env *envs[FLOWLOG_PAR_AND_MAX_BATCH]; memset(envs, 0, sizeof(envs)); for (ULO i = 0; i < exec_count; i++) { pl_and_job *ji = &jobs[i]; while (!atomic_load(&ji->done)) { usleep(1000); } if (ji->sig.except) { if (ji->tmp_snapshot) { par_state_adopt_snapshot(g_par_state, ji->tmp_snapshot); ji->tmp_snapshot = NULL; } early = ji->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (ji->sig.cut) { early = ji->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (!ji->ok) { early = cut_none(); stopped = true; atomic_store(&work->cancel, 1); } else { if (ji->tmp_snapshot) { par_state_adopt_snapshot(g_par_state, ji->tmp_snapshot); ji->tmp_snapshot = NULL; } envs[i] = ji->env_out ? ji->env_out : env_in; } last_done = i + 1; if (stopped) { break; } } if (stopped) { if (last_done < exec_count) { flowlog_wait_done(&work->done, (int)exec_count); } for (ULO i = 0; i < exec_count; i++) { pl_and_job_dispose(&jobs[i], rt_ctrl, dbg_dat_ptr); } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } *out_sig = early; return true; } pl_env *merged_env = par_and_merge_env(env_in, envs, exec_count, rt_ctrl, dbg_dat_ptr); for (ULO i = 0; i < exec_count; i++) { pl_and_job_dispose(&jobs[i], rt_ctrl, dbg_dat_ptr); } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } *out_sig = solve_goals_tls(goals + exec_count, goal_count - exec_count, merged_env, cut_barrier, exc_barrier, depth + exec_count, stop_at_first, out, sol_count); return true; } else { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } } } return false; } /* ============================================================================ * SECTION 23: WAM-lite Solver * trail-based WAM-lite goal solver and continuations. * ============================================================================ */ /* --- SUBSECTION 23.1: Solver Continuations ------------------------------- */ // Solver continuations and environment utilities. // term_max_var_id_for_scope_tr()/env_max_var_id_for_scope_tr() size scopes; wam_apply_env_bindings_to_cells() replays bindings. typedef struct pl_wam_cont { pl_term *const *goals; ULO goal_count; const void *cut_barrier; // Prolog-style tracer: when non-zero, this continuation represents the // "return to caller" boundary of a user predicate call at depth-1. uint16_t trace_pred_depth_plus1; const pl_clause *trace_clause; pl_term *trace_call_goal; const struct pl_wam_cont *next; } pl_wam_cont; static const pl_wam_cont *wam_cont_clone(const pl_wam_cont *cont, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!cont) { return NULL; } pl_wam_cont *head = NULL; pl_wam_cont *prev = NULL; const pl_wam_cont *cur = cont; for (ULO guard = 0; cur && !FLOWLOG_DEPTH_LIMIT_REACHED(guard, FLOWLOG_SOLVE_DEPTH_LIMIT); guard++) { pl_wam_cont *node = (pl_wam_cont *)pool_alloc(rt_ctrl, sizeof(*node), dbg_dat_ptr); *node = (pl_wam_cont){ .goals = cur->goals, .goal_count = cur->goal_count, .cut_barrier = cur->cut_barrier, .trace_pred_depth_plus1 = cur->trace_pred_depth_plus1, .trace_clause = cur->trace_clause, .trace_call_goal = cur->trace_call_goal, .next = NULL, }; if (prev) { prev->next = node; } else { head = node; } prev = node; cur = cur->next; } return head; } static void wam_apply_clause_bindings_arena(const pl_clause *cl, const pl_scope *to_scope, pl_term_arena *arena, pl_wam_cell *cells, ULO cell_count, pl_wam_trail *trail, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)rt_ctrl; if (!cl || !cl->env || !cl->env->count || !to_scope || !cells || !trail) { return; } for (ULO i = 0; i < cl->env->count; i++) { const pl_binding *b = &cl->env->items[i]; if (!b || (b->scope != cl->scope) || (b->var_id >= cell_count)) { continue; } pl_term *val = arena ? clone_term_with_scope_arena(b->value, cl->scope, to_scope, arena, dbg_dat_ptr, 0) : clone_term_with_scope(b->value, cl->scope, to_scope, rt_ctrl, dbg_dat_ptr); wam_trail_push(trail, dbg_dat_ptr, &cells[b->var_id]); cells[b->var_id].value = val; } } static const pl_scope *term_find_first_scope_tr(pl_term *t, ULO depth) { if (!t || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return NULL; } if (t->tag == PL_TERM_VAR) { return t->v.var.scope; } if (t->tag == PL_TERM_STRUCT && t->v.str.args) { for (ULO i = 0; i < t->v.str.arity; i++) { const pl_scope *s = term_find_first_scope_tr(t->v.str.args[i], depth + 1); if (s) { return s; } } } return NULL; } static void term_max_var_id_for_scope_tr(pl_term *t, const pl_scope *scope, ULO *io_max, ULO depth) { if (!t || !scope || !io_max || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return; } if (t->tag == PL_TERM_VAR) { if ((t->v.var.scope == scope) && (t->v.var.var_id > *io_max)) { *io_max = t->v.var.var_id; } return; } if (t->tag == PL_TERM_STRUCT && t->v.str.args) { for (ULO i = 0; i < t->v.str.arity; i++) { term_max_var_id_for_scope_tr(t->v.str.args[i], scope, io_max, depth + 1); } } } static void env_max_var_id_for_scope_tr(const pl_env *env, const pl_scope *scope, ULO *io_max, ULO depth) { if (!scope || !io_max || (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT))) { return; } for (const pl_env *cur = env; cur; cur = cur->parent) { if (!cur->items || !cur->count) { continue; } for (ULO i = 0; i < cur->count; i++) { const pl_binding *b = &cur->items[i]; if (!b) { continue; } if ((b->scope == scope) && (b->var_id > *io_max)) { *io_max = b->var_id; } if (b->value) { term_max_var_id_for_scope_tr(b->value, scope, io_max, depth + 1); } } } } static void wam_apply_env_bindings_to_cells(const pl_env *env, const pl_scope *scope, pl_wam_cell *cells, ULO cell_count) { if (!env || !scope || !cells || !cell_count) { return; } for (const pl_env *cur = env; cur; cur = cur->parent) { if (!cur->items || !cur->count) { continue; } for (ULO i = 0; i < cur->count; i++) { const pl_binding *b = &cur->items[i]; if (!b || (b->scope != scope) || (b->var_id >= cell_count)) { continue; } cells[b->var_id].value = b->value; } } } static pl_cut_signal solve_goals_wam_cb(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_wam_cont *cont) { if (!st || !sol_count) { return cut_none(); } if (stop_at_first && *sol_count) { return cut_none(); } { const pl_cut_signal lim = flowlog_inference_limit_tick(exc_barrier, rt_ctrl, dbg_dat_ptr); if (lim.except) { return lim; } } if (flowlog_cancelled()) { return cut_none(); } if (goal_count == 0) { if (cont) { const uint16_t trace_depth_plus1 = cont->trace_pred_depth_plus1; ULO trace_depth = 0; if (trace_depth_plus1) { trace_depth = (ULO)(trace_depth_plus1 - 1u); } if (prog && prog->flag_trace && trace_depth_plus1) { trace_emit_prolog_goal('<', trace_depth, "EXIT", cont->trace_call_goal, cont->trace_clause); } pl_cut_signal r = solve_goals_wam_cb(prog, q, cont->goals, cont->goal_count, st, cont->cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont->next); if (r.cut || r.except) { return r; } if (prog && prog->flag_trace && trace_depth_plus1) { trace_emit_prolog_goal('^', trace_depth, "REDO", cont->trace_call_goal, cont->trace_clause); } return cut_none(); } if (g_wam_on_solution) { on_solution_lock(); g_wam_on_solution(st, g_wam_on_solution_ctx, rt_ctrl, dbg_dat_ptr); on_solution_unlock(); } if (out) { if (g_solution_capture && g_solution_capture->out == out) { const size_t start = out->len; env_to_sbuf_wam(q, st->q_cells, out, dbg_dat_ptr); (void)solution_capture_mark(out, start); } else { if (*sol_count) { sbuf_append_cstr(out, "\n; "); } else { sbuf_append_cstr(out, " "); } env_to_sbuf_wam(q, st->q_cells, out, dbg_dat_ptr); } } (*sol_count)++; return cut_none(); } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_SOLVE_DEPTH_LIMIT)) { return cut_none(); } trace_record_goal_wam(prog, goals ? goals[0] : NULL, depth); // Conservative AND-parallelism (WAM): evaluate a prefix of deterministic, side-effect-free goals in parallel when they // do not share live variables. Bindings/scopes are merged in left-to-right order to preserve ISO-visible behavior for // pure programs. if (prog && g_par_state && prog->flag_parallel_and && (prog->flag_parallel_max_depth > 0) && ((SLO)depth < prog->flag_parallel_max_depth) && (goal_count >= 2)) { pl_term *cand[FLOWLOG_PAR_AND_MAX_BATCH]; pl_var_list cand_vars[FLOWLOG_PAR_AND_MAX_BATCH]; memset(cand_vars, 0, sizeof(cand_vars)); ULO cand_count = 0; for (ULO i = 0; i < goal_count && cand_count < FLOWLOG_PAR_AND_MAX_BATCH; i++) { pl_term *gi = deref_term_wam(goals ? goals[i] : NULL); if (!gi || !par_and_goal_is_safe_test_wam(prog, gi, rt_ctrl, dbg_dat_ptr)) { break; } pl_var_stack stv = {0}; pl_var_list vars_i; var_stack_init(&stv); var_list_init(&vars_i); term_collect_vars_wam_tr(gi, &stv, &vars_i, dbg_dat_ptr, 0); var_stack_free(&stv); bool disj = true; for (ULO j = 0; j < cand_count && disj; j++) { for (ULO v = 0; v < vars_i.count; v++) { if (var_list_contains_key(&cand_vars[j], vars_i.items[v].key)) { disj = false; break; } } } if (!disj) { var_list_free(&vars_i); break; } cand[cand_count] = gi; cand_vars[cand_count] = vars_i; // takes ownership of vars_i.items cand_count++; } if (cand_count >= 2) { ULO exec_count = cand_count; int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(exec_count - 1)); exec_count = (ULO)(1 + remote_taken); } // Free any candidate var lists we won't use (budget cap). for (ULO i = exec_count; i < cand_count; i++) { var_list_free(&cand_vars[i]); memset(&cand_vars[i], 0, sizeof(cand_vars[i])); } if (exec_count >= 2) { const ULO base_scope_count = st->scope_count; pl_and_job_wam *jobs = (pl_and_job_wam *)pool_alloc(rt_ctrl, sizeof(*jobs) * exec_count, dbg_dat_ptr); memset(jobs, 0, sizeof(*jobs) * exec_count); pl_and_work_wam *work = (pl_and_work_wam *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); *work = (pl_and_work_wam){.count = exec_count, .jobs = jobs}; atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; for (ULO i = 0; i < exec_count; i++) { jobs[i] = (pl_and_job_wam){ .prog = prog, .q = q, .goal = cand[i], .vars = cand_vars[i], .wam_in = st, .base_scope_count = base_scope_count, .cut_barrier = cut_barrier, .exc_barrier = exc_barrier, .depth = depth + 1, .work_done = &work->done, .work_cancel = &work->cancel, .ok = false, .sig = cut_none(), .wam_out = NULL, .tmp_snapshot = NULL, }; atomic_init(&jobs[i].done, 0); memset(&cand_vars[i], 0, sizeof(cand_vars[i])); // ownership moved into jobs[i].vars } bool started = flowlog_start_and_work_wam(work, 2, rt_ctrl, dbg_dat_ptr); if (!started && g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); remote_taken = 0; } // Evaluate the leftmost goal locally so it can overlap with remote jobs. pl_and_job_wam_run(&jobs[0], rt_ctrl, dbg_dat_ptr); if (!started) { for (ULO i = 1; i < exec_count; i++) { pl_and_job_wam_run(&jobs[i], rt_ctrl, dbg_dat_ptr); } } const ULO trail_mark = st->trail.count; const ULO scope_mark = st->scope_count; pl_cut_signal early = cut_none(); bool stopped = false; ULO last_done = 0; typedef struct { pl_term *var; pl_term *value; } pl_wam_bind_pair; typedef struct { pl_scope *scope; pl_wam_cell *cells; ULO count; } pl_wam_scope_import; pl_wam_state *saved_wam = g_wam_state; for (ULO i = 0; i < exec_count; i++) { pl_and_job_wam *ji = &jobs[i]; while (!atomic_load(&ji->done)) { usleep(1000); } if (ji->sig.except) { if (ji->tmp_snapshot) { par_state_adopt_snapshot(g_par_state, ji->tmp_snapshot); ji->tmp_snapshot = NULL; } early = ji->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (ji->sig.cut) { early = ji->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (!ji->ok || !ji->wam_out) { early = cut_none(); stopped = true; atomic_store(&work->cancel, 1); } else { if (ji->tmp_snapshot) { par_state_adopt_snapshot(g_par_state, ji->tmp_snapshot); ji->tmp_snapshot = NULL; } pl_wam_state *out_st = ji->wam_out; g_wam_state = out_st; // Extract bindings for the goal's free variables (as seen at dispatch time). const ULO max_pairs = ji->vars.count; pl_wam_bind_pair local_pairs[64]; pl_wam_bind_pair *pairs = local_pairs; if (max_pairs > (ULO)(sizeof(local_pairs) / sizeof(local_pairs[0]))) { pairs = (pl_wam_bind_pair *)pool_alloc(rt_ctrl, sizeof(*pairs) * max_pairs, dbg_dat_ptr); } ULO pair_count = 0; for (ULO vi = 0; vi < ji->vars.count; vi++) { pl_term *v = ji->vars.items[vi].term; pl_wam_cell *cell = wam_cell_for_var(v); if (!cell || !cell->value) { continue; } pairs[pair_count++] = (pl_wam_bind_pair){.var = v, .value = cell->value}; } // Import any new scopes introduced by the job so variable bindings remain usable while solving the suffix. const ULO base_n = ji->base_scope_count; const ULO max_scopes = (out_st->scope_count > base_n) ? (out_st->scope_count - base_n) : 0; pl_wam_scope_import local_scopes[32]; pl_wam_scope_import *imports = local_scopes; if (max_scopes > (ULO)(sizeof(local_scopes) / sizeof(local_scopes[0]))) { imports = (pl_wam_scope_import *)pool_alloc(rt_ctrl, sizeof(*imports) * max_scopes, dbg_dat_ptr); } ULO import_count = 0; for (ULO sid = base_n; sid < out_st->scope_count; sid++) { const pl_wam_scope_cells *sc = out_st->scopes ? &out_st->scopes[sid] : NULL; if (!sc || !sc->scope) { continue; } imports[import_count++] = (pl_wam_scope_import){.scope = (pl_scope *)sc->scope, .cells = sc->cells, .count = sc->count}; } // Switch back to the destination state and apply imports + bindings. g_wam_state = st; for (ULO si = 0; si < import_count; si++) { const pl_wam_scope_import *imp = &imports[si]; if (!imp->scope) { continue; } // Avoid re-pushing the same scope pointer (would remap reserved ids). bool present = false; for (ULO s0 = 0; s0 < st->scope_count; s0++) { if (st->scopes && st->scopes[s0].scope == imp->scope) { present = true; break; } } if (!present) { wam_state_push_scope_with_cells(st, imp->scope, imp->cells, imp->count, rt_ctrl, dbg_dat_ptr); } } for (ULO bi = 0; bi < pair_count; bi++) { const pl_wam_bind_pair *bp = &pairs[bi]; if (!bp->var || !bp->value) { continue; } if (!wam_bind_var(bp->var, bp->value, &st->trail, dbg_dat_ptr)) { early = cut_none(); stopped = true; atomic_store(&work->cancel, 1); break; } } if (out_st->scopes) { free(out_st->scopes); out_st->scopes = NULL; out_st->scope_count = 0; out_st->scope_cap = 0; } } last_done = i + 1; if (stopped) { break; } } g_wam_state = saved_wam; if (stopped) { if (last_done < exec_count) { flowlog_wait_done(&work->done, (int)exec_count); } for (ULO i = 0; i < exec_count; i++) { pl_and_job_wam_dispose(&jobs[i], rt_ctrl, dbg_dat_ptr); } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); remote_taken = 0; } wam_trail_unwind(&st->trail, trail_mark); st->scope_count = scope_mark; return early; } for (ULO i = 0; i < exec_count; i++) { pl_and_job_wam_dispose(&jobs[i], rt_ctrl, dbg_dat_ptr); } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); remote_taken = 0; } pl_cut_signal r = solve_goals_wam_cb(prog, q, goals + exec_count, goal_count - exec_count, st, cut_barrier, exc_barrier, depth + exec_count, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); wam_trail_unwind(&st->trail, trail_mark); st->scope_count = scope_mark; return r; } else { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } } // Clean up any unused candidate var lists (budget or analysis early-exit). for (ULO i = 0; i < cand_count; i++) { var_list_free(&cand_vars[i]); } } pl_term *raw_goal = goals ? goals[0] : NULL; pl_term *goal = deref_term_wam_and_peel_pstr_empty(raw_goal); if (!goal) { return cut_none(); } // ISO: calling a variable goal is an instantiation error. if (goal->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } // ISO: calling a non-callable term (e.g. a number) is a type error. if (term_is_list_like_pair(goal) && !term_is_list_pair(goal)) { pl_term *h = NULL; pl_term *tail = NULL; if (!term_list_like_uncons_rt(goal, &h, &tail, rt_ctrl, dbg_dat_ptr) || !h || !tail) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, "call", 1); } pl_term *st = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); st->v.str.args[0] = h; st->v.str.args[1] = tail; goal = st; } if (!term_is_callable_like(goal)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, "call", 1); } // Control constructs can appear as nested terms (e.g. via call/1, findall/3, // countall/2). These sub-terms often do not have builtin ids assigned, so // handle them by functor/arity. if (goal->tag == PL_TERM_STRUCT && goal->v.str.functor && goal->v.str.args && goal->v.str.arity == 2) { const CHR *fn = goal->v.str.functor; const ULO ar = goal->v.str.arity; if (!strcmp(fn, ",") && (ar == 2)) { pl_term *g1 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); pl_term *g2 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!g1 || !g2) { return cut_none(); } // ISO: If the first conjunct is a variable, raise instantiation_error. if (g1->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } // ISO: If a conjunct is a non-variable, non-callable term, raise type_error(callable, (G1,G2)). if (!term_is_callable_like(g1)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, ",", 2); } if ((g2->tag != PL_TERM_VAR) && !term_is_callable_like(g2)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, ",", 2); } const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = goal->v.str.args[0]; new_goals[1] = goal->v.str.args[1]; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } return solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "$if_barrier") && (ar == 2)) { pl_term *sub_goal = deref_term_wam(goal->v.str.args[0]); pl_term *outer = deref_term_wam(goal->v.str.args[1]); if (!sub_goal || !outer || (outer->tag != PL_TERM_INT)) { return cut_none(); } pl_term *drop_to_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_to_outer->v.str.args[0] = outer; const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = sub_goal; new_goals[1] = drop_to_outer; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } int inner_barrier = 0; pl_cut_signal r = solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, &inner_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.cut && (r.target == &inner_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, "->") && (ar == 2)) { pl_term *if_goal = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); pl_term *then_goal = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!if_goal || !then_goal) { return cut_none(); } if (if_goal->tag == PL_TERM_VAR || then_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(if_goal)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, "->", 2); } if (!term_is_callable_like(then_goal)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, "->", 2); } int ite_barrier = 0; pl_term *ite_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)&ite_barrier); pl_term *if_barrier = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$if_barrier", 2); if_barrier->v.str.args[0] = if_goal; if_barrier->v.str.args[1] = ite_barrier_term; pl_term *cut_goal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "!"); pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)cut_barrier); pl_term *drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_outer->v.str.args[0] = outer_barrier_term; const ULO rest = goal_count - 1; const ULO new_goal_count = 4 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = if_barrier; new_goals[1] = cut_goal; new_goals[2] = drop_outer; new_goals[3] = then_goal; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 3] = goals[i]; } pl_cut_signal r = solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, &ite_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.cut && (r.target == &ite_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, ";") && (ar == 2)) { pl_term *g1 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); pl_term *g2 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!g1 || !g2) { return cut_none(); } // ISO: If a branch is a variable, raise instantiation_error. if (g1->tag == PL_TERM_VAR || g2->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } // ISO: If a branch is a non-callable term, raise type_error(callable, (G1;G2)). if (!term_is_callable_like(g1)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, ";", 2); } if (!term_is_callable_like(g2)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, ";", 2); } // ISO if-then-else: (If -> Then ; Else) is parsed as ;(->(If,Then),Else). if ((g1->tag == PL_TERM_STRUCT) && !strcmp(g1->v.str.functor, "->") && (g1->v.str.arity == 2)) { pl_term *if_goal = deref_term_wam_and_peel_pstr_empty(g1->v.str.args[0]); pl_term *then_goal = deref_term_wam_and_peel_pstr_empty(g1->v.str.args[1]); if (!if_goal || !then_goal) { return cut_none(); } if (if_goal->tag == PL_TERM_VAR || then_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(if_goal)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, ";", 2); } if (!term_is_callable_like(then_goal)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal, &empty, ";", 2); } int ite_barrier = 0; pl_term *ite_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)&ite_barrier); pl_term *if_barrier = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$if_barrier", 2); if_barrier->v.str.args[0] = if_goal; if_barrier->v.str.args[1] = ite_barrier_term; pl_term *cut_goal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "!"); pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)cut_barrier); pl_term *drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_outer->v.str.args[0] = outer_barrier_term; const ULO rest = goal_count - 1; const ULO then_goal_count = 4 + rest; pl_term **then_goals = NULL; if (then_goal_count) { then_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * then_goal_count, dbg_dat_ptr); } then_goals[0] = if_barrier; then_goals[1] = cut_goal; then_goals[2] = drop_outer; then_goals[3] = then_goal; for (ULO i = 1; i < goal_count; i++) { then_goals[i + 3] = goals[i]; } pl_cut_signal r = solve_goals_wam_cb(prog, q, then_goals, then_goal_count, st, &ite_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.except) { return r; } if (r.cut) { if (r.target == &ite_barrier) { return cut_none(); } return r; } const ULO else_goal_count = 1 + rest; pl_term **else_goals = NULL; if (else_goal_count) { else_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * else_goal_count, dbg_dat_ptr); } else_goals[0] = g2; for (ULO i = 1; i < goal_count; i++) { else_goals[i] = goals[i]; } return solve_goals_wam_cb(prog, q, else_goals, else_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } const ULO rest = goal_count - 1; const ULO new_goal_count = 1 + rest; pl_term **goals1 = NULL; pl_term **goals2 = NULL; if (new_goal_count) { goals1 = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); goals2 = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } goals1[0] = g1; goals2[0] = g2; for (ULO i = 1; i < goal_count; i++) { goals1[i] = goals[i]; goals2[i] = goals[i]; } const ULO outer_mark = st->trail.count; pl_cut_signal r = solve_goals_wam_cb(prog, q, goals1, new_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); wam_trail_unwind(&st->trail, outer_mark); if (r.cut || r.except) { return r; } return solve_goals_wam_cb(prog, q, goals2, new_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } } // Built-ins covered by the cached builtin id. if (goal->builtin) { switch ((pl_builtin_id)goal->builtin) { case PL_BI_TRUE_0: return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); case PL_BI_FAIL_0: case PL_BI_FALSE_0: return cut_none(); case PL_BI_REPEAT_0: { for (;;) { if (flowlog_cancelled()) { return cut_none(); } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_cut_signal r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.cut || r.except) { return r; } wam_trail_unwind(&st->trail, mark); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (stop_at_first && *sol_count) { return cut_none(); } } } case PL_BI_NL_0: { streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr) || !s->writable) { return cut_none(); } stream_write_char(s, id, '\n'); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_FLUSH_OUTPUT_0: { streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr) || !s->writable) { return cut_none(); } if (flowlog_capture_user_output_stream(id)) { stream_drain_user_output_capture_if_enabled(s, id, rt_ctrl, dbg_dat_ptr); } else { (void)fflush(s->fp); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_HALT_0: g_halt_requested = true; g_halt_code = 0; return cut_to(&g_halt_barrier); case PL_BI_CUT_0: { pl_cut_signal r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.except) { return r; } if (r.cut && (r.target != cut_barrier)) { return r; } return cut_to(cut_barrier); } case PL_BI_DROP_BARRIER_1: { if (!goal->v.str.args) { return cut_none(); } pl_term *bar = deref_term_wam(goal->v.str.args[0]); if (!bar || (bar->tag != PL_TERM_INT)) { return cut_none(); } const void *new_barrier = (const void *)(uintptr_t)bar->v.int_value; return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, new_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_DROP_EXC_BARRIER_1: { if (!goal->v.str.args) { return cut_none(); } pl_term *bar = deref_term_wam(goal->v.str.args[0]); if (!bar || (bar->tag != PL_TERM_INT)) { return cut_none(); } const void *new_exc = (const void *)(uintptr_t)bar->v.int_value; return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, new_exc, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_NOT_1: { if (!goal->v.str.args || !goal->v.str.args[0]) { return cut_none(); } // ISO: \+/1 calls its argument as a goal to test provability. // - instantiation_error if Goal is a variable // - type_error(callable, Goal) if Goal is nonvar and non-callable // It must also not allow cuts in Goal to cut outside \+/1. const ULO mark = st->trail.count; ULO inner_sol = 0; int local_barrier = 0; pl_term *sub = deref_term_wam(goal->v.str.args[0]); if (!sub) { return cut_none(); } pl_term *sub_goals[1] = {sub}; // \+/1 is a probe: do not let nested successes leak into findall/bagof/setof collectors. const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; g_wam_on_solution = NULL; g_wam_on_solution_ctx = NULL; pl_cut_signal r = solve_goals_wam_cb(prog, q, sub_goals, 1, st, &local_barrier, exc_barrier, depth + 1, true, NULL, &inner_sol, rt_ctrl, dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&st->trail, mark); if (r.except) { return r; } if (r.cut && (r.target != &local_barrier)) { return r; } if (inner_sol) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_UNIFY_2: { if (!goal->v.str.args) { return cut_none(); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], goal->v.str.args[1], &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } case PL_BI_NOT_UNIFY_2: { if (!goal->v.str.args) { return cut_none(); } const ULO mark = st->trail.count; const bool ok = !unify_terms_wam(goal->v.str.args[0], goal->v.str.args[1], &st->trail, dbg_dat_ptr); wam_trail_unwind(&st->trail, mark); if (!ok) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_IDENTICAL_2: case PL_BI_NOT_IDENTICAL_2: { if (!goal->v.str.args) { return cut_none(); } const int r = compare_std_terms_wam(goal->v.str.args[0], goal->v.str.args[1], dbg_dat_ptr); const bool ok = ((pl_builtin_id)goal->builtin == PL_BI_IDENTICAL_2) ? (r == 0) : (r != 0); if (!ok) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_VARIANT_2: case PL_BI_NOT_VARIANT_2: { if (!goal->v.str.args) { return cut_none(); } const bool is_variant = term_variant_wam(goal->v.str.args[0], goal->v.str.args[1], dbg_dat_ptr); const bool ok = ((pl_builtin_id)goal->builtin == PL_BI_VARIANT_2) ? is_variant : !is_variant; if (!ok) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_TERM_LT_2: case PL_BI_TERM_LTE_2: case PL_BI_TERM_GT_2: case PL_BI_TERM_GTE_2: { if (!goal->v.str.args) { return cut_none(); } const int r = compare_std_terms_wam(goal->v.str.args[0], goal->v.str.args[1], dbg_dat_ptr); bool ok = false; switch ((pl_builtin_id)goal->builtin) { case PL_BI_TERM_LT_2: ok = (r < 0); break; case PL_BI_TERM_LTE_2: ok = (r <= 0); break; case PL_BI_TERM_GT_2: ok = (r > 0); break; case PL_BI_TERM_GTE_2: ok = (r >= 0); break; default: break; } if (!ok) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } case PL_BI_IS_2: { if (!goal->v.str.args) { return cut_none(); } pl_number val = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex_wam(goal->v.str.args[1], &val, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_env empty = {0}; pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, &empty, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_env empty = {0}; pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, &empty, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_env empty = {0}; pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, &empty, "is", 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", "is", 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", "is", 2); } pl_term *rhs = num_to_term_rt(val, rt_ctrl, dbg_dat_ptr); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], rhs, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } case PL_BI_NUM_EQ_2: case PL_BI_NUM_NE_2: case PL_BI_NUM_LT_2: case PL_BI_NUM_LTE_2: case PL_BI_NUM_GT_2: case PL_BI_NUM_GTE_2: { if (!goal->v.str.args) { return cut_none(); } const CHR *fn = (goal->tag == PL_TERM_STRUCT && goal->v.str.functor) ? goal->v.str.functor : "arith"; pl_env empty = {0}; pl_number a = {0}, b = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex_wam(goal->v.str.args[0], &a, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, &empty, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[0]); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, &empty, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[0]); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, &empty, fn, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", fn, 2); } memset(&aerr, 0, sizeof(aerr)); if (!eval_num_expr_ex_wam(goal->v.str.args[1], &b, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable", pi, &empty, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", cul, &empty, fn, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "float", cul, &empty, fn, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "undefined", fn, 2); } bool ok = false; if (!num_is_float(a) && !num_is_float(b)) { const int cmp = num_cmp(a, b); switch ((pl_builtin_id)goal->builtin) { case PL_BI_NUM_EQ_2: ok = (cmp == 0); break; case PL_BI_NUM_NE_2: ok = (cmp != 0); break; case PL_BI_NUM_LT_2: ok = (cmp < 0); break; case PL_BI_NUM_LTE_2: ok = (cmp <= 0); break; case PL_BI_NUM_GT_2: ok = (cmp > 0); break; case PL_BI_NUM_GTE_2: ok = (cmp >= 0); break; default: break; } } else { const double da = num_as_double(a); const double db = num_as_double(b); switch ((pl_builtin_id)goal->builtin) { case PL_BI_NUM_EQ_2: ok = (da == db); break; case PL_BI_NUM_NE_2: ok = (da != db); break; case PL_BI_NUM_LT_2: ok = (da < db); break; case PL_BI_NUM_LTE_2: ok = (da <= db); break; case PL_BI_NUM_GT_2: ok = (da > db); break; case PL_BI_NUM_GTE_2: ok = (da >= db); break; default: break; } } if (!ok) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } default: break; } } // Additional built-ins not covered by the cached builtin id (kept minimal for now). if (goal->tag == PL_TERM_STRUCT && goal->v.str.functor) { const CHR *fn = goal->v.str.functor; const ULO ar = goal->v.str.arity; if (ar == 1 && goal->v.str.args) { if (!strcmp(fn, "once")) { pl_term *sub_goal = deref_term_wam(goal->v.str.args[0]); if (!sub_goal) { return cut_none(); } int local_barrier = 0; pl_term *cut_goal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "!"); pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)cut_barrier); pl_term *drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_outer->v.str.args[0] = outer_barrier_term; const ULO rest = goal_count - 1; const ULO new_goal_count = 3 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = sub_goal; new_goals[1] = cut_goal; new_goals[2] = drop_outer; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 2] = goals[i]; } pl_cut_signal r = solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, &local_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.except) { return r; } if (r.cut && (r.target == &local_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, "call")) { pl_term *call_term = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (!call_term) { return cut_none(); } if (call_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(call_term)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", call_term, &empty, "call", 1); } // ISO: call/1 introduces a new cut boundary. Cuts in Goal must not cut outside call/1. int call_barrier = 0; pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)cut_barrier); pl_term *drop_outer = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop_outer->v.str.args[0] = outer_barrier_term; const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = call_term; new_goals[1] = drop_outer; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } pl_cut_signal r = solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, &call_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.except) { return r; } if (r.cut && (r.target == &call_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, "throw")) { pl_term *t = deref_term_wam(goal->v.str.args[0]); if (!t) { return cut_none(); } if (t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "nonvar"); } pl_env *exc_env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = rt_ctrl; cctx.dbg_dat_ptr = dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *copy = copy_term_wam_tr(goal->v.str.args[0], &cctx, 0); if (!copy) { copy_var_map_free(&cctx.map); free(cctx.bindings); return cut_none(); } const ULO nvars = cctx.map.next_var_id; if (cctx.bindings && nvars) { for (ULO i = 0; i < nvars && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { env_bind(exc_env, rt_ctrl, dbg_dat_ptr, scope, i, cctx.bindings[i]); } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; return except_to(exc_barrier, copy, exc_env); } if (!strcmp(fn, "var")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag == PL_TERM_VAR)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "nonvar")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag != PL_TERM_VAR)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "atom")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag == PL_TERM_ATOM)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "integer")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_integer(v)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "float")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag == PL_TERM_FLOAT)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "number")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_number(v)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "atomic")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_atomic_term(v)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "compound")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_compound_like(v)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "callable")) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_callable_like(v)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "ground")) { pl_var_stack stv; var_stack_init(&stv); const bool ok = term_is_ground_wam_tr(goal->v.str.args[0], &stv, dbg_dat_ptr, 0); var_stack_free(&stv); if (ok) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "acyclic_term")) { pl_var_stack stv; var_stack_init(&stv); const bool ok = term_is_acyclic_wam_tr(goal->v.str.args[0], &stv, dbg_dat_ptr, 0); var_stack_free(&stv); if (ok) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } } if ((!strcmp(fn, "call_with_inference_limit") || !strcmp(fn, "call_with_inference_limit_par")) && (ar == 3) && goal->v.str.args) { const bool shared = !strcmp(fn, "call_with_inference_limit_par"); const CHR *pred_name = shared ? "call_with_inference_limit_par" : "call_with_inference_limit"; const CHR *limit_pred = shared ? "$flowlog_inference_limit_shared" : "$flowlog_inference_limit"; pl_term *sub_goal = deref_term_wam(goal->v.str.args[0]); pl_term *lim_t = deref_term_wam(goal->v.str.args[1]); if (!sub_goal || !lim_t) { return cut_none(); } if (sub_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (sub_goal->tag != PL_TERM_ATOM && sub_goal->tag != PL_TERM_STRUCT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", sub_goal, &empty, pred_name, 3); } if (lim_t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (lim_t->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", lim_t, &empty, pred_name, 3); } if (lim_t->v.int_value < 0) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", lim_t, &empty, pred_name, 3); } int local_barrier = 0; const pl_call_with_inference_limit_wrap w = build_call_with_inference_limit_wrap_rt(rt_ctrl, dbg_dat_ptr, limit_pred, sub_goal, lim_t->v.int_value, goal->v.str.args[2], cut_barrier); const ULO rest = goal_count - 1; const ULO new_goal_count = 3 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = w.set_limit; new_goals[1] = w.catch_goal; new_goals[2] = w.drop_outer; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 2] = goals[i]; } pl_parallel_state *saved_par = NULL; atomic_int *saved_budget = NULL; if (!shared) { // Inference limits are per-thread. Suppress internal OR/AND-par while running // the limited Goal so worker threads cannot bypass the cap. saved_par = g_par_state; saved_budget = g_par_budget; g_par_state = NULL; g_par_budget = NULL; } pl_cut_signal r = solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, &local_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (!shared) { g_par_state = saved_par; g_par_budget = saved_budget; } if (shared) { flowlog_inference_limit_shared_clear(g_par_state); } flowlog_inference_limit_local_clear(); if (r.except) { return r; } if (r.cut && (r.target == &local_barrier)) { return cut_none(); } return r; } if (!strcmp(fn, "catch") && (ar == 3) && goal->v.str.args) { pl_term *sub_goal = deref_term_wam(goal->v.str.args[0]); pl_term *recover_goal = deref_term_wam(goal->v.str.args[2]); if (!sub_goal || !recover_goal) { return cut_none(); } int local_exc_barrier = 0; pl_term *outer_exc_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(uintptr_t)exc_barrier); pl_term *drop_exc = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_exc_barrier", 1); drop_exc->v.str.args[0] = outer_exc_term; const ULO rest = goal_count - 1; const ULO new_goal_count = 2 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = sub_goal; new_goals[1] = drop_exc; for (ULO i = 1; i < goal_count; i++) { new_goals[i + 1] = goals[i]; } pl_cut_signal r = solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, cut_barrier, &local_exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); if (r.except && (r.target == &local_exc_barrier)) { // Caught an exception thrown from within Goal; try to unify with Catcher. const ULO mark = st->trail.count; const ULO scope_mark = st->scope_count; const pl_scope *exc_scope = term_find_first_scope_tr(r.except_term, 0); if (exc_scope) { ULO max_var_id = 0; term_max_var_id_for_scope_tr(r.except_term, exc_scope, &max_var_id, 0); env_max_var_id_for_scope_tr(r.except_env, exc_scope, &max_var_id, 0); const ULO var_count = max_var_id + 1; pl_wam_cell *cells = wam_state_push_scope(st, (pl_scope *)exc_scope, var_count, rt_ctrl, dbg_dat_ptr); if (cells && var_count) { wam_apply_env_bindings_to_cells(r.except_env, exc_scope, cells, var_count); } } if (!unify_terms_wam(goal->v.str.args[1], r.except_term, &st->trail, dbg_dat_ptr)) { // Not caught: retarget to outer handler and propagate. wam_trail_unwind(&st->trail, mark); st->scope_count = scope_mark; r.target = exc_barrier; return r; } const ULO recover_goal_count = 1 + rest; pl_term **recover_goals = NULL; if (recover_goal_count) { recover_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * recover_goal_count, dbg_dat_ptr); } recover_goals[0] = recover_goal; for (ULO i = 1; i < goal_count; i++) { recover_goals[i] = goals[i]; } pl_cut_signal rr = solve_goals_wam_cb(prog, q, recover_goals, recover_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); wam_trail_unwind(&st->trail, mark); st->scope_count = scope_mark; return rr; } if (r.except && (r.target == exc_barrier)) { return r; } return r; } if (!strcmp(fn, "unify_with_occurs_check") && (ar == 2) && goal->v.str.args) { const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam_occurs(goal->v.str.args[0], goal->v.str.args[1], &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "term_variables") && (ar == 2) && goal->v.str.args) { // Validate output argument is list/partial list. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term_wam(out0); if (!out_term) { return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", out0, &empty, "term_variables", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "term_variables", 2); } } } pl_var_stack stv; pl_var_list vl; var_stack_init(&stv); var_list_init(&vl); term_collect_vars_wam_tr(goal->v.str.args[0], &stv, &vl, dbg_dat_ptr, 0); var_stack_free(&stv); pl_term *list = NULL; if (!vl.count) { list = make_nil_rt(dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * vl.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < vl.count; i++) { elems[i] = vl.items[i].term; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, vl.count); free(elems); } var_list_free(&vl); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "copy_term") && (ar == 2) && goal->v.str.args) { const ULO mark = st->trail.count; const ULO scope_mark = st->scope_count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = rt_ctrl; cctx.dbg_dat_ptr = dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *copied = copy_term_wam_tr(goal->v.str.args[0], &cctx, 0); pl_wam_cell *cells = NULL; const ULO var_count = cctx.map.next_var_id; if (var_count) { cells = wam_state_push_scope(st, scope, var_count, rt_ctrl, dbg_dat_ptr); if (cells && cctx.bindings) { for (ULO i = 0; i < var_count && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { cells[i].value = cctx.bindings[i]; } } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; pl_cut_signal r = cut_none(); if (copied && unify_terms_wam(goal->v.str.args[1], copied, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); st->scope_count = scope_mark; return r; } if (!strcmp(fn, "numbervars") && (ar == 3) && goal->v.str.args) { pl_term *start_term = deref_term_wam(goal->v.str.args[1]); if (!start_term || (start_term->tag == PL_TERM_VAR)) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (start_term->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", start_term, &empty, "numbervars", 3); } pl_term *end_term = deref_term_wam(goal->v.str.args[2]); if (end_term && (end_term->tag != PL_TERM_VAR) && (end_term->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", end_term, &empty, "numbervars", 3); } const ULO mark = st->trail.count; SLO counter = start_term->v.int_value; pl_var_stack stv; var_stack_init(&stv); const bool ok = term_numbervars_wam_tr(goal->v.str.args[0], &stv, &counter, &st->trail, rt_ctrl, dbg_dat_ptr, 0); var_stack_free(&stv); if (!ok) { wam_trail_unwind(&st->trail, mark); return cut_none(); } pl_term *end_val = make_int_rt(rt_ctrl, dbg_dat_ptr, counter); pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], end_val, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "subsumes_term") && (ar == 2) && goal->v.str.args) { pl_term *pair = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$subsumes_pair", 2); pair->v.str.args[0] = goal->v.str.args[0]; pair->v.str.args[1] = goal->v.str.args[1]; const ULO mark = st->trail.count; const ULO scope_mark = st->scope_count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = rt_ctrl; cctx.dbg_dat_ptr = dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *pair_c = copy_term_wam_tr(pair, &cctx, 0); if (!pair_c || (pair_c->tag != PL_TERM_STRUCT) || strcmp(pair_c->v.str.functor, "$subsumes_pair") || (pair_c->v.str.arity != 2)) { copy_var_map_free(&cctx.map); free(cctx.bindings); wam_trail_unwind(&st->trail, mark); st->scope_count = scope_mark; return cut_none(); } const ULO var_count = cctx.map.next_var_id; pl_wam_cell *cells = NULL; if (var_count) { cells = wam_state_push_scope(st, scope, var_count, rt_ctrl, dbg_dat_ptr); if (cells && cctx.bindings) { for (ULO i = 0; i < var_count && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { cells[i].value = cctx.bindings[i]; } } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; pl_term *gen = pair_c->v.str.args[0]; pl_term *spec = pair_c->v.str.args[1]; if (!gen || !spec) { wam_trail_unwind(&st->trail, mark); st->scope_count = scope_mark; return cut_none(); } pl_var_stack stv; pl_var_list rigid; var_stack_init(&stv); var_list_init(&rigid); term_collect_vars_wam_tr(spec, &stv, &rigid, dbg_dat_ptr, 0); var_stack_free(&stv); const bool ok = unify_terms_subsumes_wam_tr(gen, spec, &st->trail, &rigid, rt_ctrl, dbg_dat_ptr, 0); var_list_free(&rigid); wam_trail_unwind(&st->trail, mark); st->scope_count = scope_mark; if (ok) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } // Atom / character / number conversions (ISO core, integers + floats). if (!strcmp(fn, "char_code") && (ar == 2) && goal->v.str.args) { pl_term *ch = deref_term_wam(goal->v.str.args[0]); pl_term *code = deref_term_wam(goal->v.str.args[1]); if (!ch || !code) { return cut_none(); } if ((ch->tag == PL_TERM_VAR) && (code->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "char_code", 2); } if (ch->tag != PL_TERM_VAR) { if (ch->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch, &empty, "char_code", 2); } if (!atom_is_char(ch)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch, &empty, "char_code", 2); } } if (code->tag != PL_TERM_VAR && code->tag != PL_TERM_INT && code->tag != PL_TERM_BIGINT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code, &empty, "char_code", 2); } SLO code_value = 0; if (code->tag == PL_TERM_INT) { code_value = code->v.int_value; } else if (code->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(code->v.bigint, &code_value)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "char_code", 2); } } if (code->tag != PL_TERM_VAR) { if (code_value <= 0 || !unicode_codepoint_valid((uint32_t)code_value)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "char_code", 2); } } if ((ch->tag == PL_TERM_VAR) && (code->tag != PL_TERM_VAR)) { pl_term *ct = make_char_atom_rt(dbg_dat_ptr, (uint32_t)code_value); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], ct, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if ((code->tag == PL_TERM_VAR) && (ch->tag == PL_TERM_ATOM)) { uint32_t cp = 0; if (!atom_codepoint(ch, &cp)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch, &empty, "char_code", 2); } pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)cp); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], it, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if ((ch->tag == PL_TERM_ATOM) && (code->tag != PL_TERM_VAR)) { uint32_t cp = 0; if (!atom_codepoint(ch, &cp) || ((SLO)cp != code_value)) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "atom_length") && (ar == 2) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, &empty, "atom_length", 2); } pl_term *len_in = deref_term_wam(goal->v.str.args[1]); if (len_in && (len_in->tag != PL_TERM_VAR) && (len_in->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len_in, &empty, "atom_length", 2); } const SLO len = (SLO)strlen(a->v.atom_name ? a->v.atom_name : ""); pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, len); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], it, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "atom_concat") && (ar == 3) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); pl_term *b = deref_term_wam(goal->v.str.args[1]); pl_term *c = deref_term_wam(goal->v.str.args[2]); if (!a || !b || !c) { return cut_none(); } if ((a->tag != PL_TERM_VAR) && (a->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, &empty, "atom_concat", 3); } if ((b->tag != PL_TERM_VAR) && (b->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", b, &empty, "atom_concat", 3); } if ((c->tag != PL_TERM_VAR) && (c->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", c, &empty, "atom_concat", 3); } if ((c->tag == PL_TERM_VAR) && ((a->tag == PL_TERM_VAR) || (b->tag == PL_TERM_VAR))) { // ISO: would enumerate infinitely many solutions. return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom_concat", 3); } if (c->tag == PL_TERM_ATOM) { const CHR *s = c->v.atom_name ? c->v.atom_name : ""; const size_t n = strlen(s); for (size_t i = 0; i <= n; i++) { if (stop_at_first && *sol_count) { return cut_none(); } CHR *p = (CHR *)malloc(i + 1); CHR *qbuf = (CHR *)malloc((n - i) + 1); if (!p || !qbuf) { free(p); free(qbuf); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(p, s, i); p[i] = '\0'; memcpy(qbuf, s + i, n - i); qbuf[n - i] = '\0'; pl_term *pa = make_atom_rt(rt_ctrl, dbg_dat_ptr, p); pl_term *pb = make_atom_rt(rt_ctrl, dbg_dat_ptr, qbuf); free(p); free(qbuf); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], pa, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], pb, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } return cut_none(); } // Concatenate A and B to produce C. const CHR *sa = ((pl_term *)a)->v.atom_name ? ((pl_term *)a)->v.atom_name : ""; const CHR *sb = ((pl_term *)b)->v.atom_name ? ((pl_term *)b)->v.atom_name : ""; const size_t na = strlen(sa); const size_t nb = strlen(sb); CHR *buf = (CHR *)malloc(na + nb + 1); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(buf, sa, na); memcpy(buf + na, sb, nb); buf[na + nb] = '\0'; pl_term *cat = make_atom_rt(rt_ctrl, dbg_dat_ptr, buf); free(buf); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], cat, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "sub_atom") && (ar == 5) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, &empty, "sub_atom", 5); } pl_term *before_t = deref_term_wam(goal->v.str.args[1]); pl_term *len_t = deref_term_wam(goal->v.str.args[2]); pl_term *after_t = deref_term_wam(goal->v.str.args[3]); pl_term *sub_t = deref_term_wam(goal->v.str.args[4]); if (!before_t || !len_t || !after_t || !sub_t) { return cut_none(); } if ((before_t->tag != PL_TERM_VAR) && (before_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", before_t, &empty, "sub_atom", 5); } if ((len_t->tag != PL_TERM_VAR) && (len_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len_t, &empty, "sub_atom", 5); } if ((after_t->tag != PL_TERM_VAR) && (after_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", after_t, &empty, "sub_atom", 5); } if ((sub_t->tag != PL_TERM_VAR) && (sub_t->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", sub_t, &empty, "sub_atom", 5); } const bool before_is_var = (before_t->tag == PL_TERM_VAR); const bool len_is_var = (len_t->tag == PL_TERM_VAR); const bool after_is_var = (after_t->tag == PL_TERM_VAR); const SLO before_fixed = before_is_var ? 0 : before_t->v.int_value; const SLO len_fixed = len_is_var ? 0 : len_t->v.int_value; const SLO after_fixed = after_is_var ? 0 : after_t->v.int_value; if (!before_is_var && (before_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", before_t, &empty, "sub_atom", 5); } if (!len_is_var && (len_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", len_t, &empty, "sub_atom", 5); } if (!after_is_var && (after_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", after_t, &empty, "sub_atom", 5); } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); for (size_t before = 0; before <= n; before++) { if (!before_is_var && ((SLO)before != before_fixed)) { continue; } const size_t max_len = n - before; for (size_t lenv = 0; lenv <= max_len; lenv++) { if (!len_is_var && ((SLO)lenv != len_fixed)) { continue; } const size_t after = n - before - lenv; if (!after_is_var && ((SLO)after != after_fixed)) { continue; } if (stop_at_first && *sol_count) { return cut_none(); } CHR *subbuf = (CHR *)malloc(lenv + 1); if (!subbuf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(subbuf, s + before, lenv); subbuf[lenv] = '\0'; pl_term *suba = make_atom_rt(rt_ctrl, dbg_dat_ptr, subbuf); free(subbuf); pl_term *bt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)before); pl_term *lt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)lenv); pl_term *at = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)after); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], bt, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], lt, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[3], at, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[4], suba, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } } return cut_none(); } if (!strcmp(fn, "sub_string") && (ar == 5) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, &empty, "sub_string", 5); } pl_term *before_t = deref_term_wam(goal->v.str.args[1]); pl_term *len_t = deref_term_wam(goal->v.str.args[2]); pl_term *after_t = deref_term_wam(goal->v.str.args[3]); pl_term *sub_t = deref_term_wam(goal->v.str.args[4]); if (!before_t || !len_t || !after_t || !sub_t) { return cut_none(); } if ((before_t->tag != PL_TERM_VAR) && (before_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", before_t, &empty, "sub_string", 5); } if ((len_t->tag != PL_TERM_VAR) && (len_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len_t, &empty, "sub_string", 5); } if ((after_t->tag != PL_TERM_VAR) && (after_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", after_t, &empty, "sub_string", 5); } if ((sub_t->tag != PL_TERM_VAR) && (sub_t->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", sub_t, &empty, "sub_string", 5); } const bool before_is_var = (before_t->tag == PL_TERM_VAR); const bool len_is_var = (len_t->tag == PL_TERM_VAR); const bool after_is_var = (after_t->tag == PL_TERM_VAR); const SLO before_fixed = before_is_var ? 0 : before_t->v.int_value; const SLO len_fixed = len_is_var ? 0 : len_t->v.int_value; const SLO after_fixed = after_is_var ? 0 : after_t->v.int_value; if (!before_is_var && (before_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", before_t, &empty, "sub_string", 5); } if (!len_is_var && (len_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", len_t, &empty, "sub_string", 5); } if (!after_is_var && (after_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", after_t, &empty, "sub_string", 5); } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); for (size_t before = 0; before <= n; before++) { if (!before_is_var && ((SLO)before != before_fixed)) { continue; } const size_t max_len = n - before; for (size_t lenv = 0; lenv <= max_len; lenv++) { if (!len_is_var && ((SLO)lenv != len_fixed)) { continue; } const size_t after = n - before - lenv; if (!after_is_var && ((SLO)after != after_fixed)) { continue; } if (stop_at_first && *sol_count) { return cut_none(); } CHR *subbuf = (CHR *)malloc(lenv + 1); if (!subbuf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } memcpy(subbuf, s + before, lenv); subbuf[lenv] = '\0'; pl_term *suba = make_atom_rt(rt_ctrl, dbg_dat_ptr, subbuf); free(subbuf); pl_term *bt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)before); pl_term *lt = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)lenv); pl_term *at = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)after); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], bt, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], lt, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[3], at, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[4], suba, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } } return cut_none(); } if ((!strcmp(fn, "atom_chars") || !strcmp(fn, "atom_codes")) && (ar == 2) && goal->v.str.args) { const bool use_codes = !strcmp(fn, "atom_codes"); pl_term *a = deref_term_wam(goal->v.str.args[0]); pl_term *l = deref_term_wam(goal->v.str.args[1]); if (!a || !l) { return cut_none(); } if ((a->tag == PL_TERM_VAR) && (l->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if ((a->tag != PL_TERM_VAR) && (a->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", a, &empty, fn, 2); } if (a->tag == PL_TERM_ATOM) { // ISO: validate List is a proper/partial list and that nonvar elements have the right type. pl_term *l_chk = (pl_term *)term_peel_pstr_empty_const(l); if ((l_chk->tag != PL_TERM_VAR) && !term_is_nil(l_chk) && !term_is_list_like_pair(l_chk)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", l_chk, &empty, fn, 2); } if (l->tag != PL_TERM_VAR) { pl_term *cur = goal->v.str.args[1]; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (term_is_list_like_pair(cur) && !term_is_list_pair(cur)) { pl_env empty = {0}; if (use_codes) { const pl_term *h = NULL; const pl_term *t = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term tail_tmp = {0}; if (!term_list_like_uncons_view(cur, &h, &t, &head_tmp, head_ch, &tail_tmp) || !h || !h->v.atom_name) { return cut_none(); } uint32_t hcp = 0; if (!atom_codepoint(h, &hcp)) { hcp = PL_UTF8_REPLACEMENT; } pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, hcp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } continue; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag != PL_TERM_VAR) { if (use_codes) { if (h->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", h, &empty, fn, 2); } } else { if (!atom_is_char(h)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", h, &empty, fn, 2); } } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } } } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); pl_term *list = NULL; if (use_codes) { pl_term *tail = make_nil_rt(dbg_dat_ptr); for (size_t i = n; i > 0; i--) { pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(unsigned char)s[i - 1]); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = it; cons->v.str.args[1] = tail; tail = cons; } list = tail; } else { list = make_pstr_rt(rt_ctrl, dbg_dat_ptr, (const unsigned char *)s, (ULO)n, make_nil_rt(dbg_dat_ptr)); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } // Construct atom from list. if (l->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if ((l->tag == PL_TERM_PSTR) || term_is_nil(l)) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_wam(goal->v.str.args[1], &pstr_cstr, &pstr_len, &pstr_buf, dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (use_codes && (pstr_len > 0)) { uint32_t cp = 0; (void)utf8_decode_one_lenient(pstr_cstr, (size_t)pstr_len, &cp); if (pstr_buf) { free(pstr_buf); } pl_env empty = {0}; pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, cp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } pl_term *at = make_atom_rt(rt_ctrl, dbg_dat_ptr, (const CHR *)pstr_cstr); if (pstr_buf) { free(pstr_buf); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], at, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (pst == PL_PSTR_CSTR_INSTANTIATION) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } } pl_term_vec elems = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &elems, dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term_wam(elems.items[i]); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", e, &empty, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", e, &empty, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } buf[off] = '\0'; term_vec_free(&elems); pl_term *at = make_atom_rt(rt_ctrl, dbg_dat_ptr, buf); free(buf); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], at, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if ((!strcmp(fn, "number_chars") || !strcmp(fn, "number_codes")) && (ar == 2) && goal->v.str.args) { const bool use_codes = !strcmp(fn, "number_codes"); pl_term *n = deref_term_wam(goal->v.str.args[0]); pl_term *l = deref_term_wam(goal->v.str.args[1]); if (!n || !l) { return cut_none(); } if ((n->tag == PL_TERM_VAR) && (l->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if ((n->tag != PL_TERM_VAR) && (n->tag != PL_TERM_INT) && (n->tag != PL_TERM_BIGINT) && (n->tag != PL_TERM_FLOAT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "number", n, &empty, fn, 2); } // If Number is given, accept any List that parses to the same number. // For partial lists (variables in the list), unify with the canonical list. if (n->tag != PL_TERM_VAR) { bool has_var = false; // ISO: validate List is a proper/partial list and that nonvar elements have the right type. pl_term *l_chk = (pl_term *)term_peel_pstr_empty_const(l); if ((l_chk->tag != PL_TERM_VAR) && !term_is_nil(l_chk) && !term_is_list_like_pair(l_chk)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", l_chk, &empty, fn, 2); } if (l->tag != PL_TERM_VAR) { pl_term *cur = goal->v.str.args[1]; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { has_var = true; break; } if (term_is_list_like_pair(cur) && !term_is_list_pair(cur)) { pl_env empty = {0}; if (use_codes) { const pl_term *h = NULL; const pl_term *t = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term tail_tmp = {0}; if (!term_list_like_uncons_view(cur, &h, &t, &head_tmp, head_ch, &tail_tmp) || !h || !h->v.atom_name) { return cut_none(); } uint32_t hcp = 0; if (!atom_codepoint(h, &hcp)) { hcp = PL_UTF8_REPLACEMENT; } pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, hcp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } continue; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag == PL_TERM_VAR) { has_var = true; } else { if (use_codes) { SLO code = 0; if (h->tag == PL_TERM_INT) { code = h->v.int_value; } else if (h->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(h->v.bigint, &code)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", h, &empty, fn, 2); } if ((code < 0) || (code > 255)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { if (!atom_is_char(h)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", h, &empty, fn, 2); } } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } } } if ((l->tag != PL_TERM_VAR) && !has_var) { pl_parsed_number pn = {0}; bool parsed = false; if (!use_codes && ((l->tag == PL_TERM_PSTR) || term_is_nil(l))) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_wam(goal->v.str.args[1], &pstr_cstr, &pstr_len, &pstr_buf, dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (!parse_number_iso_cstr((const CHR *)pstr_cstr, &pn, rt_ctrl, dbg_dat_ptr)) { if (pstr_buf) { free(pstr_buf); } return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } if (pstr_buf) { free(pstr_buf); } parsed = true; } } if (!parsed) { pl_term_vec elems = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &elems, dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); has_var = true; } else if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } else { const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term_wam(elems.items[i]); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); has_var = true; break; } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", e, &empty, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", e, &empty, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } if (!has_var) { buf[off] = '\0'; term_vec_free(&elems); if (!parse_number_iso_cstr(buf, &pn, rt_ctrl, dbg_dat_ptr)) { free(buf); return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } free(buf); } } } if (!has_var) { if (!pn.is_float) { if ((n->tag == PL_TERM_INT) && !pn.is_big && (n->v.int_value == pn.ival)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (n->tag == PL_TERM_BIGINT) { const int cmp = pn.is_big ? bigint_cmp(n->v.bigint, pn.big) : bigint_cmp_slo(n->v.bigint, pn.ival); if (cmp == 0) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } } } else if ((n->tag == PL_TERM_FLOAT) && (n->v.float_value == pn.fval)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } } // Unify canonical list with List (variables/partial lists). const char *tmp = NULL; char ibuf[64]; char fbuf[128]; char *big_buf = NULL; if (n->tag == PL_TERM_INT) { (void)snprintf(ibuf, sizeof(ibuf), "%ld", (long)n->v.int_value); tmp = ibuf; } else if (n->tag == PL_TERM_BIGINT) { big_buf = bigint_to_cstr(n->v.bigint); if (!big_buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } tmp = big_buf; } else { float_to_cstr(n->v.float_value, fbuf, sizeof(fbuf)); tmp = fbuf; } const CHR *s = (const CHR *)(tmp ? tmp : ""); const size_t len = strlen(s); pl_term *list = NULL; if (use_codes) { pl_term *tail = make_nil_rt(dbg_dat_ptr); for (size_t i = len; i > 0; i--) { pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(unsigned char)s[i - 1]); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = it; cons->v.str.args[1] = tail; tail = cons; } list = tail; } else { list = make_pstr_rt(rt_ctrl, dbg_dat_ptr, (const unsigned char *)s, (ULO)len, make_nil_rt(dbg_dat_ptr)); } if (big_buf) { free(big_buf); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } // Parse number from List. if ((l->tag == PL_TERM_PSTR) || term_is_nil(l)) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_wam(goal->v.str.args[1], &pstr_cstr, &pstr_len, &pstr_buf, dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (use_codes && (pstr_len > 0)) { uint32_t cp = 0; (void)utf8_decode_one_lenient(pstr_cstr, (size_t)pstr_len, &cp); if (pstr_buf) { free(pstr_buf); } pl_env empty = {0}; pl_term *culprit = make_char_atom_rt(dbg_dat_ptr, cp); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } pl_parsed_number pn = {0}; if (!parse_number_iso_cstr((const CHR *)pstr_cstr, &pn, rt_ctrl, dbg_dat_ptr)) { if (pstr_buf) { free(pstr_buf); } return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } if (pstr_buf) { free(pstr_buf); } pl_term *num = pn.is_float ? make_float_rt(rt_ctrl, dbg_dat_ptr, pn.fval) : (pn.is_big ? make_bigint_rt(rt_ctrl, dbg_dat_ptr, pn.big) : make_int_rt(rt_ctrl, dbg_dat_ptr, pn.ival)); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], num, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (pst == PL_PSTR_CSTR_INSTANTIATION) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } } pl_term_vec elems = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &elems, dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term_wam(elems.items[i]); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 2); } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", e, &empty, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", e, &empty, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } buf[off] = '\0'; term_vec_free(&elems); pl_parsed_number pn = {0}; if (!parse_number_iso_cstr(buf, &pn, rt_ctrl, dbg_dat_ptr)) { free(buf); return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "illegal_number", fn, 2); } free(buf); if (n->tag == PL_TERM_VAR) { pl_term *num = pn.is_float ? make_float_rt(rt_ctrl, dbg_dat_ptr, pn.fval) : (pn.is_big ? make_bigint_rt(rt_ctrl, dbg_dat_ptr, pn.big) : make_int_rt(rt_ctrl, dbg_dat_ptr, pn.ival)); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], num, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!pn.is_float) { if ((n->tag == PL_TERM_INT) && !pn.is_big && (n->v.int_value == pn.ival)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (n->tag == PL_TERM_BIGINT) { const int cmp = pn.is_big ? bigint_cmp(n->v.bigint, pn.big) : bigint_cmp_slo(n->v.bigint, pn.ival); if (cmp == 0) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } } } else if ((n->tag == PL_TERM_FLOAT) && (n->v.float_value == pn.fval)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(fn, "=..") && (ar == 2) && goal->v.str.args) { pl_term *t = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (t && (t->tag != PL_TERM_VAR)) { // Validate list argument is a (proper or partial) list. pl_term *list0 = goal->v.str.args[1]; pl_term *list_term = deref_term_wam(list0); if (!list_term) { return cut_none(); } if (list_term->tag != PL_TERM_VAR) { pl_term *cur = list_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, &empty, "=..", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "=..", 2); } } } pl_term *list = NULL; if (term_is_compound_like(t)) { pl_term *fname = NULL; SLO arity_val = 0; if (!term_functor_arity_rt(t, &fname, &arity_val, rt_ctrl, dbg_dat_ptr) || !fname || (fname->tag != PL_TERM_ATOM) || (arity_val < 0)) { return cut_none(); } const ULO n = (ULO)arity_val; pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * (n + 1)); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } elems[0] = fname; for (ULO i = 0; i < n; i++) { pl_term *argi = NULL; if (!term_compound_arg_rt(t, (SLO)i + 1, &argi, rt_ctrl, dbg_dat_ptr) || !argi) { free(elems); return cut_none(); } elems[i + 1] = argi; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, n + 1); free(elems); } else { pl_term *elems[1] = {t}; list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, 1); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } // Construct term from list. pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &v, dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st_list == PL_LIST_STATUS_TYPE_ERROR || (v.count == 0)) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[1], &empty, "=..", 2); } pl_term *head = deref_term_wam(v.items[0]); if (!head) { term_vec_free(&v); return cut_none(); } if (head->tag == PL_TERM_VAR) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_term *res = NULL; if (v.count == 1) { if (head->tag != PL_TERM_ATOM && head->tag != PL_TERM_INT && head->tag != PL_TERM_FLOAT) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atomic", head, &empty, "=..", 2); } res = head; } else { if (head->tag != PL_TERM_ATOM) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", head, &empty, "=..", 2); } const ULO n = v.count - 1; if (n > 255) { term_vec_free(&v); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "=..", 2); } pl_term *stt = make_struct_rt(rt_ctrl, dbg_dat_ptr, head->v.atom_name, n); for (ULO i = 0; i < n; i++) { stt->v.str.args[i] = v.items[i + 1]; } res = stt; } term_vec_free(&v); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], res, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "functor") && (ar == 3) && goal->v.str.args) { pl_term *t = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (t && (t->tag != PL_TERM_VAR)) { pl_term *name = NULL; SLO arity_val = 0; if (!term_functor_arity_rt(t, &name, &arity_val, rt_ctrl, dbg_dat_ptr)) { return cut_none(); } pl_term *arity_term = make_int_rt(rt_ctrl, dbg_dat_ptr, arity_val); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], name, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], arity_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } // Construct a term from Name/Arity. pl_term *name = deref_term_wam(goal->v.str.args[1]); pl_term *arity_term = deref_term_wam(goal->v.str.args[2]); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (arity_term->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, &empty, "functor", 3); } const SLO n = arity_term->v.int_value; if (n < 0) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "functor", 3); } const SLO max_arity = 255; // current_prolog_flag(max_arity, 255) if (n > max_arity) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "functor", 3); } if (name->tag != PL_TERM_ATOM && name->tag != PL_TERM_INT && name->tag != PL_TERM_FLOAT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atomic", name, &empty, "functor", 3); } if (n == 0) { const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], name, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (name->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name, &empty, "functor", 3); } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); (void)wam_state_push_scope(st, scope, (ULO)n, rt_ctrl, dbg_dat_ptr); pl_term *ct = make_struct_rt(rt_ctrl, dbg_dat_ptr, name->v.atom_name, (ULO)n); for (ULO i = 0; i < (ULO)n; i++) { ct->v.str.args[i] = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, scope, i); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], ct, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); return r; } if (!strcmp(fn, "arg") && (ar == 3) && goal->v.str.args) { pl_term *n = deref_term_wam(goal->v.str.args[0]); if (!n) { return cut_none(); } if (n->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (n->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", n, &empty, "arg", 3); } pl_term *t = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!t) { return cut_none(); } if (t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (!term_is_compound_like(t)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "compound", t, &empty, "arg", 3); } const SLO idx = n->v.int_value; if (idx < 0) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", n, &empty, "arg", 3); } const ULO arity = term_compound_arity(t); if (idx == 0 || (ULO)idx > arity) { return cut_none(); } pl_term *val = NULL; if (!term_compound_arg_rt(t, idx, &val, rt_ctrl, dbg_dat_ptr) || !val) { return cut_none(); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], val, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "compare") && (ar == 3) && goal->v.str.args) { pl_term *ord0 = deref_term_wam(goal->v.str.args[0]); if (!ord0) { return cut_none(); } if (ord0->tag != PL_TERM_VAR) { if (ord0->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", ord0, &empty, "compare", 3); } if (strcmp(ord0->v.atom_name, "<") && strcmp(ord0->v.atom_name, ">") && strcmp(ord0->v.atom_name, "=")) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "order", ord0, &empty, "compare", 3); } } const int cr = compare_std_terms_wam(goal->v.str.args[1], goal->v.str.args[2], dbg_dat_ptr); const CHR *sym = (cr < 0) ? "<" : (cr > 0) ? ">" : "="; if (ord0->tag == PL_TERM_ATOM) { if (!strcmp(ord0->v.atom_name, sym)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } pl_term *ord = make_atom_rt(rt_ctrl, dbg_dat_ptr, sym); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], ord, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, ":") && (ar == 2) && goal->v.str.args) { pl_term *qual_goal = deref_term_wam(goal->v.str.args[1]); if (!qual_goal) { return cut_none(); } // Defer ISO meta-call errors (e.g., instantiation_error(callable)) to call/1. pl_term *call_goal = make_struct_rt(rt_ctrl, dbg_dat_ptr, "call", 1); call_goal->v.str.args[0] = qual_goal; const ULO new_goal_count = 1 + (goal_count - 1); pl_term **new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); new_goals[0] = call_goal; for (ULO i = 1; i < goal_count; i++) { new_goals[i] = goals[i]; } return solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "call") && (ar >= 2) && (ar <= 8) && goal->v.str.args) { pl_term *closure = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (!closure) { return cut_none(); } if (closure->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(closure)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", closure, &empty, "call", ar); } pl_term *module_term = NULL; pl_term *base = closure; if ((closure->tag == PL_TERM_STRUCT) && !strcmp(closure->v.str.functor, ":") && (closure->v.str.arity == 2)) { module_term = deref_term_wam(closure->v.str.args[0]); base = deref_term_wam_and_peel_pstr_empty(closure->v.str.args[1]); if (!base) { return cut_none(); } if (base->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (!term_is_callable_like(base)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", base, &empty, "call", ar); } } const ULO extra_n = ar - 1; pl_term *expanded = NULL; if (base->tag == PL_TERM_ATOM) { expanded = make_struct_rt(rt_ctrl, dbg_dat_ptr, base->v.atom_name, extra_n); for (ULO i = 0; i < extra_n; i++) { expanded->v.str.args[i] = deref_term_wam(goal->v.str.args[i + 1]); } } else { pl_term *fname = NULL; SLO base_arity = 0; if (!term_functor_arity_rt(base, &fname, &base_arity, rt_ctrl, dbg_dat_ptr) || !fname || (fname->tag != PL_TERM_ATOM) || (base_arity <= 0)) { return cut_none(); } expanded = make_struct_rt(rt_ctrl, dbg_dat_ptr, fname->v.atom_name, (ULO)base_arity + extra_n); for (SLO i = 0; i < base_arity; i++) { pl_term *argi = NULL; if (!term_compound_arg_rt(base, i + 1, &argi, rt_ctrl, dbg_dat_ptr) || !argi) { return cut_none(); } expanded->v.str.args[i] = deref_term_wam(argi); } for (ULO i = 0; i < extra_n; i++) { expanded->v.str.args[(ULO)base_arity + i] = deref_term_wam(goal->v.str.args[i + 1]); } } if (!expanded) { return cut_none(); } pl_term *call_goal = expanded; if (module_term) { pl_term *qual = make_struct_rt(rt_ctrl, dbg_dat_ptr, ":", 2); qual->v.str.args[0] = module_term; qual->v.str.args[1] = expanded; call_goal = qual; } const ULO new_goal_count = 1 + (goal_count - 1); pl_term **new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); new_goals[0] = call_goal; for (ULO i = 1; i < goal_count; i++) { new_goals[i] = goals[i]; } return solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "$flowlog_sleep_ms") && (ar == 1) && goal->v.str.args) { pl_term *ms_t = deref_term_wam(goal->v.str.args[0]); if (!ms_t) { return cut_none(); } if (ms_t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (ms_t->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", ms_t, &empty, "$flowlog_sleep_ms", 1); } if (ms_t->v.int_value < 0) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", ms_t, &empty, "$flowlog_sleep_ms", 1); } // Keep it bounded to avoid absurd sleep values in case this is accidentally exposed. SLO ms = ms_t->v.int_value; if (ms > 600000) { ms = 600000; } usleep((useconds_t)((unsigned long)ms * 1000UL)); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "$flowlog_inference_limit") && (ar == 1) && goal->v.str.args) { pl_term *lim_t = deref_term_wam(goal->v.str.args[0]); if (!lim_t) { return cut_none(); } if (lim_t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (lim_t->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", lim_t, &empty, "$flowlog_inference_limit", 1); } if (lim_t->v.int_value < 0) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", lim_t, &empty, "$flowlog_inference_limit", 1); } flowlog_inference_limit_local_set((uint64_t)lim_t->v.int_value); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "$flowlog_inference_limit_shared") && (ar == 1) && goal->v.str.args) { pl_term *lim_t = deref_term_wam(goal->v.str.args[0]); if (!lim_t) { return cut_none(); } if (lim_t->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (lim_t->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", lim_t, &empty, "$flowlog_inference_limit_shared", 1); } if (lim_t->v.int_value < 0) { pl_env empty = {0}; return throw_domain_error( exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", lim_t, &empty, "$flowlog_inference_limit_shared", 1); } flowlog_inference_limit_shared_set(g_par_state, (uint64_t)lim_t->v.int_value); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } // ISO-ish stream predicates (core I/O) - WAM-lite. if (!strcmp(fn, "current_input") && (ar == 1) && goal->v.str.args) { streams_init(dbg_dat_ptr); pl_term *st_term = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, g_streams.current_input); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], st_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "current_output") && (ar == 1) && goal->v.str.args) { streams_init(dbg_dat_ptr); pl_term *st_term = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, g_streams.current_output); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], st_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "current_error") && (ar == 1) && goal->v.str.args) { streams_init(dbg_dat_ptr); pl_term *st_term = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, 2); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], st_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "set_input") && (ar == 1) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_input", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_input", 1); } if (!s->readable) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "set_input", 1); } streams_init(dbg_dat_ptr); g_streams.current_input = id; return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "set_output") && (ar == 1) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_output", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_output", 1); } if (!s->writable) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "set_output", 1); } streams_init(dbg_dat_ptr); g_streams.current_output = id; return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "set_error") && (ar == 1) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_error", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_error", 1); } if (!s->writable) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "set_error", 1); } // Trealla's set_error/1 currently validates but does not affect current_error/1. return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "open") && ((ar == 3) || (ar == 4)) && goal->v.str.args) { pl_env empty = {0}; pl_term *file = deref_term_wam(goal->v.str.args[0]); pl_term *mode = deref_term_wam(goal->v.str.args[1]); if (!file || !mode) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, &empty, "open", 4); } if (mode->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (mode->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", mode, &empty, "open", 4); } streams_init(dbg_dat_ptr); bool binary_stream = false; // default: text_stream bool repositionable = true; unsigned char eof_action = PL_EOF_ACTION_EOF_CODE; bool bom_specified = false; bool use_bom = false; const CHR *alias_name = NULL; if (ar == 4) { pl_term *opts = deref_term_wam(goal->v.str.args[3]); if (!opts) { return cut_none(); } if (opts->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } pl_term *cur = opts; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", cur, &empty, "open", 4); } pl_term *opt = deref_term_wam(cur->v.str.args[0]); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (opt->tag != PL_TERM_STRUCT) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(opt->v.str.functor, "type") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(v->v.atom_name, "binary")) { binary_stream = true; } else if (!strcmp(v->v.atom_name, "text")) { binary_stream = false; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "reposition") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(v->v.atom_name, "true")) { repositionable = true; } else if (!strcmp(v->v.atom_name, "false")) { repositionable = false; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "eof_action") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(v->v.atom_name, "eof_code")) { eof_action = PL_EOF_ACTION_EOF_CODE; } else if (!strcmp(v->v.atom_name, "reset")) { eof_action = PL_EOF_ACTION_RESET; } else if (!strcmp(v->v.atom_name, "error")) { eof_action = PL_EOF_ACTION_ERROR; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "alias") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (v->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", v, &empty, "open", 4); } alias_name = v->v.atom_name; } else if (!strcmp(opt->v.str.functor, "bom") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } bom_specified = true; if (!strcmp(v->v.atom_name, "true")) { use_bom = true; } else if (!strcmp(v->v.atom_name, "false")) { use_bom = false; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "encoding") && opt->v.str.arity == 1) { // Only UTF-8 is supported for now; reject other encodings. pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (v->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", v, &empty, "open", 4); } if (strcmp(v->v.atom_name, "UTF-8")) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "open", 4); } } } const CHR *m = mode->v.atom_name ? mode->v.atom_name : ""; const bool readable = !strcmp(m, "read"); const bool writable = !strcmp(m, "write") || !strcmp(m, "append"); if (!readable && !writable) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "io_mode", mode, &empty, "open", 4); } char smode[8]; smode[0] = '\0'; if (!strcmp(m, "read")) { (void)snprintf(smode, sizeof(smode), "%s", binary_stream ? "rb" : "r"); } else if (!strcmp(m, "write")) { (void)snprintf(smode, sizeof(smode), "%s", binary_stream ? "wb" : "w"); } else if (!strcmp(m, "append")) { (void)snprintf(smode, sizeof(smode), "%s", binary_stream ? "ab" : "a"); } FILE *fp = fopen(file->v.atom_name ? file->v.atom_name : "", smode); if (!fp) { if (!strcmp(m, "read")) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, &empty, "open", 4); } return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "open", "source_sink", file, &empty, "open", 4); } const SLO id = stream_alloc_id(dbg_dat_ptr); if (id < 0) { (void)fclose(fp); return cut_none(); } g_streams.items[id] = (pl_stream){.open = true, .readable = readable, .writable = writable, .binary = binary_stream, .repositionable = repositionable, .eof_action = eof_action, .bom = false, .encoding = binary_stream ? NULL : strdup("UTF-8"), .fp = fp, .alias = alias_name ? strdup(alias_name) : NULL, .file_name = strdup(file->v.atom_name ? file->v.atom_name : ""), .line_count = 1, .line_pos = 1, .mode = strdup(mode->v.atom_name ? mode->v.atom_name : "")}; if (!binary_stream) { bool is_regular = false; { struct stat stbuf; const int fd = fileno(fp); if (fd >= 0 && (fstat(fd, &stbuf) == 0) && S_ISREG(stbuf.st_mode)) { is_regular = true; } } if (!is_regular && !bom_specified) { bom_specified = true; use_bom = false; } pl_stream *s = &g_streams.items[id]; if (readable && (!bom_specified || use_bom)) { const int b0 = fgetc(fp); const int b1 = fgetc(fp); const int b2 = fgetc(fp); if (b0 == 0xEF && b1 == 0xBB && b2 == 0xBF) { s->bom = true; } else { if (b2 != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)b2); } if (b1 != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)b1); } if (b0 != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)b0); } } if (feof(fp)) { clearerr(fp); } } else if (!strcmp(m, "write") && use_bom) { const unsigned char bom_bytes[3] = {0xEF, 0xBB, 0xBF}; (void)fwrite(bom_bytes, 1, sizeof(bom_bytes), fp); s->bom = true; } } pl_term *st_out = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], st_out, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } else { (void)fclose(fp); stream_free_pushback(&g_streams.items[id]); stream_free_meta(&g_streams.items[id]); g_streams.items[id] = (pl_stream){0}; } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "close") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "close", ar); } if (ar == 2) { pl_term *opts = deref_term_wam(goal->v.str.args[1]); if (!opts) { return cut_none(); } if (opts->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } pl_term *cur = opts; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "close_option"); } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", cur, &empty, "close", 2); } pl_term *opt = deref_term_wam(cur->v.str.args[0]); if (!opt) { return cut_none(); } if (opt->tag != PL_TERM_STRUCT || opt->v.str.arity != 1 || strcmp(opt->v.str.functor, "force")) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "close_option", opt, &empty, "close", 2); } pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag != PL_TERM_ATOM || strcmp(v->v.atom_name, "true")) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "close_option", opt, &empty, "close", 2); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "close", 2); } } } streams_init(dbg_dat_ptr); if (id >= 0 && id <= 2) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "close", ar); } if (s->fp) { (void)fclose(s->fp); } stream_free_pushback(s); stream_free_meta(s); g_streams.items[id] = (pl_stream){0}; if (g_streams.current_input == id) { g_streams.current_input = 0; } if (g_streams.current_output == id) { g_streams.current_output = 1; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "set_stream") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_stream", 2); } streams_init(dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_stream", 2); } pl_term *opt = deref_term_wam(goal->v.str.args[1]); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_property"); } if (opt->tag != PL_TERM_STRUCT) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_property", opt, &empty, "set_stream", 2); } if (!strcmp(opt->v.str.functor, "alias") && (opt->v.str.arity >= 1)) { pl_term *alias_term = deref_term_wam(opt->v.str.args[0]); if (!alias_term) { return cut_none(); } if (alias_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_option"); } if (alias_term->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_property", opt, &empty, "set_stream", 2); } // Clear alias from any other stream, then set it on this stream. for (size_t i = 0; i < g_streams.cap; i++) { pl_stream *s2 = &g_streams.items[i]; if (!s2->open || !s2->alias) { continue; } if (!strcmp(s2->alias, alias_term->v.atom_name)) { free(s2->alias); s2->alias = NULL; } } free(s->alias); s->alias = strdup(alias_term->v.atom_name); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } // Known but immutable stream properties: fail without error. if ((opt->v.str.arity == 1) && (!strcmp(opt->v.str.functor, "type") || !strcmp(opt->v.str.functor, "mode") || !strcmp(opt->v.str.functor, "file_name") || !strcmp(opt->v.str.functor, "file_no") || !strcmp(opt->v.str.functor, "line_count") || !strcmp(opt->v.str.functor, "position") || !strcmp(opt->v.str.functor, "reposition") || !strcmp(opt->v.str.functor, "end_of_stream") || !strcmp(opt->v.str.functor, "eof_action") || !strcmp(opt->v.str.functor, "bom") || !strcmp(opt->v.str.functor, "encoding") || !strcmp(opt->v.str.functor, "newline"))) { return cut_none(); } return cut_none(); } if (!strcmp(fn, "set_stream_position") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); pl_term *pos_term = deref_term_wam(goal->v.str.args[1]); if (!st_term || !pos_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_stream_position", 2); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "set_stream_position", 2); } const bool repositionable = s->repositionable; if (!repositionable) { if (pos_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "reposition,stream"); } return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "reposition", "stream", pos_term, &empty, "set_stream_position", 2); } if (pos_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_position"); } if (pos_term->tag != PL_TERM_INT) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream_position", pos_term, &empty, "set_stream_position", 2); } const SLO pos = pos_term->v.int_value; if (pos < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "position", pos_term, &empty, "set_stream_position", 2); } if (!stream_set_position(s, (long)pos)) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "reposition", "stream", pos_term, &empty, "set_stream_position", 2); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "stream_property") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); pl_term *st_term = deref_term_wam(goal->v.str.args[0]); pl_term *prop_term = deref_term_wam(goal->v.str.args[1]); if (!st_term || !prop_term) { return cut_none(); } const bool prop_is_var = (prop_term->tag == PL_TERM_VAR); const bool stream_is_var = (st_term->tag == PL_TERM_VAR); SLO fixed_id = -1; if (!stream_is_var) { if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &fixed_id)) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "stream_property", 2); } pl_stream *s = NULL; if (!stream_lookup(fixed_id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "stream_property", 2); } // Trealla: aliases work for property lookup but do not enumerate. if ((st_term->tag == PL_TERM_ATOM) && prop_is_var) { return cut_none(); } } const size_t start = stream_is_var ? 0 : (size_t)fixed_id; const size_t end = stream_is_var ? g_streams.cap : ((size_t)fixed_id + 1); for (size_t i = start; i < end; i++) { const SLO id = (SLO)i; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { continue; } pl_term *stream_val = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); pl_term *props[16]; ULO prop_n = 0; if (s->alias) { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "alias", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->alias); props[prop_n++] = p; } if (s->file_name) { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "file_name", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->file_name); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "file_no", 1); p->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)fileno(s->fp)); props[prop_n++] = p; } if (s->mode) { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "mode", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->mode); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "type", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->binary ? "binary" : "text"); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "line_count", 1); p->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)(s->line_count ? s->line_count : 1)); props[prop_n++] = p; } { SLO pos = 0; if (id == 1 || id == 2) { pos = -1; } else if (id >= 4) { const long p = ftell(s->fp); pos = (p >= 0) ? (SLO)p : -1; if (pos >= 0 && s->readable && s->pushback_count) { pos -= (SLO)s->pushback_count; if (pos < 0) { pos = 0; } } } pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "position", 1); p->v.str.args[0] = make_int_rt(rt_ctrl, dbg_dat_ptr, pos); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "reposition", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->repositionable ? "true" : "false"); props[prop_n++] = p; } { const CHR *eos = "not"; if (!s->readable) { eos = (id <= 2) ? "not" : "at"; } else if (s->pushback_count) { eos = "not"; } else if (s->eof_action == PL_EOF_ACTION_RESET) { eos = "not"; } else if (s->eos_past) { eos = "past"; } else if ((id >= 4) && stream_regular_file_at_end(s)) { eos = "at"; } else { eos = "not"; } pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "end_of_stream", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, eos); props[prop_n++] = p; } { const CHR *ea = "eof_code"; if (s->eof_action == PL_EOF_ACTION_ERROR) { ea = "error"; } else if (s->eof_action == PL_EOF_ACTION_RESET) { ea = "reset"; } pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "eof_action", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, ea); props[prop_n++] = p; } if (!s->binary) { { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "bom", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->bom ? "true" : "false"); props[prop_n++] = p; } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "encoding", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, s->encoding ? s->encoding : "UTF-8"); props[prop_n++] = p; } } if (s->readable) { props[prop_n++] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "input"); } if (s->writable) { props[prop_n++] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "output"); } { pl_term *p = make_struct_rt(rt_ctrl, dbg_dat_ptr, "newline", 1); p->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "posix"); props[prop_n++] = p; } for (ULO pi = 0; pi < prop_n; pi++) { if (stop_at_first && *sol_count) { return cut_none(); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if ((stream_is_var ? unify_terms_wam(goal->v.str.args[0], stream_val, &st->trail, dbg_dat_ptr) : true) && unify_terms_wam(goal->v.str.args[1], props[pi], &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } } return cut_none(); } if (!strcmp(fn, "nl") && (ar == 1) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "nl", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "nl", 1); } if (!s->writable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "nl", 1); } stream_write_char(s, id, '\n'); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "flush_output") && (ar == 1) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "flush_output", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "flush_output", 1); } if (!s->writable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "flush_output", 1); } if (flowlog_capture_user_output_stream(id)) { stream_drain_user_output_capture_if_enabled(s, id, rt_ctrl, dbg_dat_ptr); } else { (void)fflush(s->fp); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "at_end_of_stream") && (ar == 1) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "at_end_of_stream", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "at_end_of_stream", 1); } if (!s->readable) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "at_end_of_stream", 1); } if (s->pushback_count) { return cut_none(); } const int c = fgetc(s->fp); if (c == EOF) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); return cut_none(); } if (!strcmp(fn, "tab") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *n_term = deref_term_wam(goal->v.str.args[0]); if (ar == 2) { if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return cut_none(); } n_term = deref_term_wam(goal->v.str.args[1]); } if (!n_term || n_term->tag != PL_TERM_INT) { return cut_none(); } const SLO n = n_term->v.int_value; if (n < 0 || n > 65535) { return cut_none(); } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr) || !s->writable) { return cut_none(); } for (SLO i = 0; i < n; i++) { stream_write_char(s, id, ' '); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "get_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "get_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "get_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag != PL_TERM_VAR && code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, &empty, "get_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "get_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "get_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "get_code", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (code == -1); pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, code); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(code_arg, it, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "peek_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "peek_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "peek_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag != PL_TERM_VAR && code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, &empty, "peek_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "peek_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "peek_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "peek_code", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); } } pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, code); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(code_arg, it, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "put_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "put_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "put_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, &empty, "put_code", ar); } const SLO code = code_term->v.int_value; if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "put_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "put_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "put_code", ar); } if (code < 0 || code > 255) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "put_code", ar); } stream_write_char(s, id, (char)(unsigned char)code); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "unget_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "unget_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "unget_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (code_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", code_term, &empty, "unget_code", ar); } const SLO code = code_term->v.int_value; if (code < -1) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character_code", "unget_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "unget_code", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "unget_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "unget_code", ar); } stream_pushback_push(s, dbg_dat_ptr, code); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "get_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "get_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "get_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag != PL_TERM_VAR && ch_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, &empty, "get_char", ar); } if (ch_term->tag == PL_TERM_ATOM) { if (strcmp(ch_term->v.atom_name, "end_of_file") && (strlen(ch_term->v.atom_name) != 1)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, &empty, "get_char", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "get_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "get_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "get_char", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (code == -1); pl_term *out_ch = NULL; if (code == -1) { out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { CHR tmp[2] = {(CHR)(unsigned char)code, '\0'}; out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, tmp); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(char_arg, out_ch, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "peek_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "peek_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "peek_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag != PL_TERM_VAR && ch_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, &empty, "peek_char", ar); } if (ch_term->tag == PL_TERM_ATOM) { if (strcmp(ch_term->v.atom_name, "end_of_file") && (strlen(ch_term->v.atom_name) != 1)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, &empty, "peek_char", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "peek_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "peek_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "peek_char", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); } } pl_term *out_ch = NULL; if (code == -1) { out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { CHR tmp[2] = {(CHR)(unsigned char)code, '\0'}; out_ch = make_atom_rt(rt_ctrl, dbg_dat_ptr, tmp); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(char_arg, out_ch, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "put_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "put_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "put_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character"); } if (ch_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch_term, &empty, "put_char", ar); } if (strlen(ch_term->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", ch_term, &empty, "put_char", ar); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "put_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "put_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "put_char", ar); } stream_write_char(s, id, (char)(unsigned char)ch_term->v.atom_name[0]); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "unget_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "unget_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "unget_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character"); } if (ch_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, &empty, "unget_char", ar); } SLO code = -1; if (!strcmp(ch_term->v.atom_name, "end_of_file")) { code = -1; } else { if (strlen(ch_term->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_character", ch_term, &empty, "unget_char", ar); } code = (SLO)(unsigned char)ch_term->v.atom_name[0]; } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "unget_char", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "unget_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "unget_char", ar); } stream_pushback_push(s, dbg_dat_ptr, code); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "get_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "get_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "get_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag != PL_TERM_VAR && byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, &empty, "get_byte", ar); } if (byte_term->tag == PL_TERM_INT) { const SLO v = byte_term->v.int_value; if (v < -1 || v > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, &empty, "get_byte", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "get_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "get_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "text_stream", sid, &empty, "get_byte", ar); } SLO byte = -1; if (s->pushback_count) { byte = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); byte = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (byte == -1); pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, byte); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(byte_arg, it, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "peek_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "peek_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "peek_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag != PL_TERM_VAR && byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, &empty, "peek_byte", ar); } if (byte_term->tag == PL_TERM_INT) { const SLO v = byte_term->v.int_value; if (v < -1 || v > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, &empty, "peek_byte", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "peek_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "peek_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "text_stream", sid, &empty, "peek_byte", ar); } SLO byte = -1; if (s->pushback_count) { byte = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); byte = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); } } pl_term *it = make_int_rt(rt_ctrl, dbg_dat_ptr, byte); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(byte_arg, it, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "put_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "put_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "put_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "byte"); } if (byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "byte", byte_term, &empty, "put_byte", ar); } const SLO byte = byte_term->v.int_value; if (byte < 0 || byte > 255) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "put_byte", ar); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "put_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "put_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "text_stream", sid, &empty, "put_byte", ar); } stream_write_char(s, id, (char)(unsigned char)byte); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "unget_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "unget_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "unget_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte"); } if (byte_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, &empty, "unget_byte", ar); } const SLO byte = byte_term->v.int_value; if (byte < -1 || byte > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "in_byte", byte_term, &empty, "unget_byte", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "unget_byte", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "unget_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "text_stream", sid, &empty, "unget_byte", ar); } stream_pushback_push(s, dbg_dat_ptr, byte); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "read") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "read", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "read", 2); } return cut_none(); } if (!s->readable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "read", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "read", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "read", ar); } if (!solution_stream_wait_for_input(s)) { return cut_none(); } stream_flush_prompt_output_before_read(s, rt_ctrl, dbg_dat_ptr); const ULO term_base_line = s->line_count ? s->line_count : 1; const ULO term_base_col = s->line_pos ? s->line_pos : 1; const char *term_src_name = (s->file_name && s->file_name[0]) ? s->file_name : ((s->alias && s->alias[0]) ? s->alias : ""); pl_sbuf src; sbuf_init(&src, rt_ctrl, dbg_dat_ptr); const bool char_conv_on = prog ? prog->flag_char_conversion : false; const unsigned char *char_conv_table = prog ? prog->char_conv_table : NULL; const bool character_escapes = prog ? prog->flag_character_escapes : true; bool is_eof = false; const CHR *syntax_error_reason = NULL; const CHR *syntax_error_pos = NULL; if (!stream_read_term_src( s, &src, &is_eof, char_conv_on, char_conv_table, character_escapes, dbg_dat_ptr, &syntax_error_reason, &syntax_error_pos)) { if (syntax_error_reason) { report_stream_syntax_error(term_src_name, term_base_line, term_base_col, src.buf, syntax_error_pos, syntax_error_reason); } sbuf_free(&src); if (syntax_error_reason) { return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, syntax_error_reason, "read", ar); } return cut_none(); } pl_term *read_term_val = NULL; pl_scope *scope = NULL; if (is_eof) { read_term_val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { pl_parse p = {0}; p.src_name = term_src_name; p.src_base_line = term_base_line; p.src_base_col = term_base_col; p.rt_ctrl = rt_ctrl; p.dbg_dat_ptr = dbg_dat_ptr; p.ops = prog ? prog->op_overrides : NULL; p.double_quotes = prog ? prog->flag_double_quotes : PL_DQ_CHARS; p.character_escapes = character_escapes; lex_init(&p.lx, src.buf ? src.buf : "", char_conv_on, char_conv_table, character_escapes); pl_var_table vt = {0}; scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); read_term_val = parse_term(&p, &vt, scope, true, 1200); if (peek_tok(&p).type == TOK_DOT) { (void)take_tok(&p); } else { expect_tok(&p, TOK_DOT); } if (peek_tok(&p).type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected trailing tokens after read/1", dbg_dat_ptr); } (void)wam_state_push_scope(st, scope, vt.count, rt_ctrl, dbg_dat_ptr); } sbuf_free(&src); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(term_arg, read_term_val, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (scope) { wam_state_pop_scope(st, scope); } return r; } if (!strcmp(fn, "read_term") && ((ar == 2) || (ar == 3)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; pl_term *opts_arg = goal->v.str.args[1]; if (ar == 3) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "read_term", 3); } term_arg = goal->v.str.args[1]; opts_arg = goal->v.str.args[2]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 3) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "read_term", 3); } return cut_none(); } if (!s->readable) { if (ar == 3) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", st_term, &empty, "read_term", 3); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "stream", cur, &empty, "read_term", 2); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "binary_stream", sid, &empty, "read_term", ar); } if (!solution_stream_wait_for_input(s)) { return cut_none(); } pl_term *opts_term = deref_term_wam(opts_arg); if (!opts_term) { return cut_none(); } if (opts_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } if (!term_is_list_pair(opts_term) && !term_is_nil(opts_term)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", opts_term, &empty, "read_term", ar); } pl_term *vars_target = NULL; pl_term *varnames_target = NULL; pl_term *singletons_target = NULL; bool character_escapes = prog ? prog->flag_character_escapes : true; pl_double_quotes_mode dq_mode = prog ? prog->flag_double_quotes : PL_DQ_CHARS; pl_term *opt_cur = opts_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, opt_cur); while (1) { opt_cur = deref_term_wam(opt_cur); if (term_is_nil(opt_cur)) { break; } if (opt_cur->tag == PL_TERM_VAR) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, "read_term", ar); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } if (!term_is_list_pair(opt_cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", opts_term, &empty, "read_term", ar); } pl_term *opt = deref_term_wam(opt_cur->v.str.args[0]); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, "read_term", ar); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "variables")) { vars_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "variable_names")) { varnames_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "singletons")) { singletons_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "character_escapes")) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } character_escapes = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "double_quotes")) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } if (!strcmp(v->v.atom_name, "atom")) { dq_mode = PL_DQ_ATOM; } else if (!strcmp(v->v.atom_name, "codes")) { dq_mode = PL_DQ_CODES; } else if (!strcmp(v->v.atom_name, "chars")) { dq_mode = PL_DQ_CHARS; } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } } else { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } opt_cur = opt_cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "read_term", ar); } } stream_flush_prompt_output_before_read(s, rt_ctrl, dbg_dat_ptr); const ULO term_base_line = s->line_count ? s->line_count : 1; const ULO term_base_col = s->line_pos ? s->line_pos : 1; const char *term_src_name = (s->file_name && s->file_name[0]) ? s->file_name : ((s->alias && s->alias[0]) ? s->alias : ""); pl_sbuf src; sbuf_init(&src, rt_ctrl, dbg_dat_ptr); const bool char_conv_on = prog ? prog->flag_char_conversion : false; const unsigned char *char_conv_table = prog ? prog->char_conv_table : NULL; bool is_eof = false; const CHR *syntax_error_reason = NULL; const CHR *syntax_error_pos = NULL; if (!stream_read_term_src( s, &src, &is_eof, char_conv_on, char_conv_table, character_escapes, dbg_dat_ptr, &syntax_error_reason, &syntax_error_pos)) { if (syntax_error_reason) { report_stream_syntax_error(term_src_name, term_base_line, term_base_col, src.buf, syntax_error_pos, syntax_error_reason); } sbuf_free(&src); if (syntax_error_reason) { return throw_syntax_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, syntax_error_reason, "read_term", ar); } return cut_none(); } pl_term *read_term_val = NULL; pl_var_list vars_list = {0}; pl_var_list named_list = {0}; pl_var_list singletons_list = {0}; pl_scope *scope = NULL; if (is_eof) { read_term_val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "end_of_file"); } else { pl_parse p = {0}; p.src_name = term_src_name; p.src_base_line = term_base_line; p.src_base_col = term_base_col; p.rt_ctrl = rt_ctrl; p.dbg_dat_ptr = dbg_dat_ptr; p.ops = prog ? prog->op_overrides : NULL; p.double_quotes = dq_mode; p.character_escapes = character_escapes; lex_init(&p.lx, src.buf ? src.buf : "", char_conv_on, char_conv_table, character_escapes); pl_var_table vt = {0}; scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); read_term_val = parse_term(&p, &vt, scope, true, 1200); expect_tok(&p, TOK_DOT); if (peek_tok(&p).type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected trailing tokens after read_term/*", dbg_dat_ptr); } (void)wam_state_push_scope(st, scope, vt.count, rt_ctrl, dbg_dat_ptr); if (vars_target || varnames_target || singletons_target) { pl_var_stack stv; var_stack_init(&stv); var_list_init(&vars_list); term_collect_vars_tr(read_term_val, NULL, &stv, &vars_list, dbg_dat_ptr, 0); var_stack_free(&stv); if (varnames_target || singletons_target) { // Build a named var list in first-appearance order, skipping anonymous '_'. var_list_init(&named_list); var_list_init(&singletons_list); pl_var_count_list counts; var_count_list_init(&counts); pl_var_stack st2; var_stack_init(&st2); term_count_vars_tr(read_term_val, NULL, &st2, &counts, dbg_dat_ptr, 0); var_stack_free(&st2); for (ULO i = 0; i < counts.count; i++) { pl_term *v = counts.items[i].term; if (!v || v->tag != PL_TERM_VAR) { continue; } const CHR *nm = v->v.var.var_name; if (!nm || (nm[0] == '_' && nm[1] == '\0')) { continue; // anonymous '_' } var_list_add_unique(&named_list, dbg_dat_ptr, counts.items[i].key, v); if (counts.items[i].count == 1) { var_list_add_unique(&singletons_list, dbg_dat_ptr, counts.items[i].key, v); } } var_count_list_free(&counts); } } } sbuf_free(&src); const ULO mark = st->trail.count; bool ok = unify_terms_wam(term_arg, read_term_val, &st->trail, dbg_dat_ptr); if (ok && vars_target) { pl_term *list = NULL; if (!vars_list.count) { list = make_nil_rt(dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * vars_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < vars_list.count; i++) { elems[i] = vars_list.items[i].term; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, vars_list.count); free(elems); } ok = unify_terms_wam(vars_target, list, &st->trail, dbg_dat_ptr); } if (ok && varnames_target) { pl_term *list = NULL; if (!named_list.count) { list = make_nil_rt(dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * named_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < named_list.count; i++) { pl_term *v = named_list.items[i].term; pl_term *pair = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); pair->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, v->v.var.var_name ? v->v.var.var_name : ""); pair->v.str.args[1] = v; elems[i] = pair; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, named_list.count); free(elems); } ok = unify_terms_wam(varnames_target, list, &st->trail, dbg_dat_ptr); } if (ok && singletons_target) { pl_term *list = NULL; if (!singletons_list.count) { list = make_nil_rt(dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * singletons_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } for (ULO i = 0; i < singletons_list.count; i++) { pl_term *v = singletons_list.items[i].term; pl_term *pair = make_struct_rt(rt_ctrl, dbg_dat_ptr, "=", 2); pair->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, v->v.var.var_name ? v->v.var.var_name : ""); pair->v.str.args[1] = v; elems[i] = pair; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, singletons_list.count); free(elems); } ok = unify_terms_wam(singletons_target, list, &st->trail, dbg_dat_ptr); } var_list_free(&vars_list); var_list_free(&named_list); var_list_free(&singletons_list); pl_cut_signal r = cut_none(); if (ok) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (scope) { wam_state_pop_scope(st, scope); } return r; } if (!strcmp(fn, "file_to_chars") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *file = deref_term_wam(goal->v.str.args[0]); if (!file) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, &empty, "file_to_chars", 2); } pl_term *chars = NULL; int io_errno = 0; const flowlog_file_chars_status stc = flowlog_file_to_chars_term(file->v.atom_name, rt_ctrl, dbg_dat_ptr, &chars, &io_errno); if (stc != FLOWLOG_FILE_CHARS_OK) { if (stc == FLOWLOG_FILE_CHARS_ERR_INVALID) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character_code", "file_to_chars", 2); } if (stc == FLOWLOG_FILE_CHARS_ERR_TOO_LARGE) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "file_to_chars", 2); } if (io_errno == EACCES || io_errno == EPERM) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "open", "source_sink", file, &empty, "file_to_chars", 2); } if (stc == FLOWLOG_FILE_CHARS_ERR_OPEN) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, &empty, "file_to_chars", 2); } return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "source_sink", file, &empty, "file_to_chars", 2); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], chars, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if ((!strcmp(fn, "file_to_bytes") || !strcmp(fn, "file_to_byte")) && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *file = deref_term_wam(goal->v.str.args[0]); if (!file) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, &empty, fn, 2); } pl_term *bytes = NULL; int io_errno = 0; const flowlog_file_bytes_status stc = flowlog_file_to_bytes_term(file->v.atom_name, rt_ctrl, dbg_dat_ptr, &bytes, &io_errno); if (stc != FLOWLOG_FILE_BYTES_OK) { if (stc == FLOWLOG_FILE_BYTES_ERR_TOO_LARGE) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", fn, 2); } if (io_errno == EACCES || io_errno == EPERM) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "open", "source_sink", file, &empty, fn, 2); } if (stc == FLOWLOG_FILE_BYTES_ERR_OPEN) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "source_sink", file, &empty, fn, 2); } return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "input", "source_sink", file, &empty, fn, 2); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], bytes, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "write") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "write", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "write", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "write", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "write", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "write", ar); } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = false, .ignore_ops = false, .numbervars = true}; pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "writeq") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "writeq", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "writeq", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "writeq", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "writeq", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "writeq", ar); } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false, .numbervars = true}; pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "write_canonical") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "write_canonical", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "write_canonical", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "write_canonical", 2); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "write_canonical", 1); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "write_canonical", ar); } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = true}; pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "write_term") && ((ar == 2) || (ar == 3)) && goal->v.str.args) { pl_env empty = {0}; streams_init(dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; pl_term *opts_arg = goal->v.str.args[1]; if (ar == 3) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], dbg_dat_ptr, &id)) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "write_term", 3); } term_arg = goal->v.str.args[1]; opts_arg = goal->v.str.args[2]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { if (ar == 3) { return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "stream", st_term, &empty, "write_term", 3); } return cut_none(); } if (!s->writable) { if (ar == 3) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", st_term, &empty, "write_term", 3); } pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "write_term", 2); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "write_term", ar); } pl_write_opts wopts = {.quoted = false, .ignore_ops = false}; pl_term *opts_term = deref_term_wam(opts_arg); if (!opts_term) { return cut_none(); } if (opts_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } pl_write_var_name_map vnames; write_var_name_map_init(&vnames); bool have_var_names = false; pl_term *cur = opts_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { // Trealla reports the predicate indicator for partial option lists. write_var_name_map_free(&vnames); pl_env *env = alloc_empty_env_rt(rt_ctrl, dbg_dat_ptr); pl_term *formal = make_atom_rt(rt_ctrl, dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, "write_term", ar); return except_to(exc_barrier, make_error_rt(formal, ctx, rt_ctrl, dbg_dat_ptr), env); } if (!term_is_list_pair(cur)) { write_var_name_map_free(&vnames); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", cur, &empty, "write_term", ar); } pl_term *opt = deref_term_wam(cur->v.str.args[0]); if (!opt) { write_var_name_map_free(&vnames); return cut_none(); } if (opt->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (opt->tag != PL_TERM_STRUCT) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(opt->v.str.functor, "quoted") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.quoted = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.quoted = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "ignore_ops") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.ignore_ops = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.ignore_ops = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "numbervars") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.numbervars = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.numbervars = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "fullstop") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.fullstop = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.fullstop = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "nl") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.nl = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.nl = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "max_depth") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_INT) { write_var_name_map_free(&vnames); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", v, &empty, "write_term", ar); } if (v->v.int_value < 0) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", v, &empty, "write_term", ar); } wopts.max_depth = (ULO)v->v.int_value; } else if (!strcmp(opt->v.str.functor, "variable_names") && (opt->v.str.arity == 1)) { have_var_names = true; pl_term *pairs = deref_term_wam(opt->v.str.args[0]); if (!pairs) { write_var_name_map_free(&vnames); return cut_none(); } if (pairs->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option"); } pl_term *lc = pairs; pl_list_cycle_guard cg2; list_cycle_guard_init(&cg2, lc); while (1) { lc = deref_term_wam(lc); if (!lc) { write_var_name_map_free(&vnames); return cut_none(); } if (term_is_nil(lc)) { break; } if (lc->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!term_is_list_pair(lc)) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_term *pair = deref_term_wam(lc->v.str.args[0]); if (!pair || pair->tag != PL_TERM_STRUCT || pair->v.str.arity != 2 || strcmp(pair->v.str.functor, "=")) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_term *nm = deref_term_wam(pair->v.str.args[0]); if (!nm) { write_var_name_map_free(&vnames); return cut_none(); } if (nm->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_term *var = deref_term_wam(pair->v.str.args[1]); if (!var) { write_var_name_map_free(&vnames); return cut_none(); } if (var->tag != PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_var_key k = {.scope = var->v.var.scope, .var_id = var->v.var.var_id}; write_var_name_add_unique(&vnames, dbg_dat_ptr, k, nm->v.atom_name); lc = lc->v.str.args[1]; if (list_cycle_guard_step_wam(&cg2)) { write_var_name_map_free(&vnames); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "write_term", ar); } } } else { write_var_name_map_free(&vnames); return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { write_var_name_map_free(&vnames); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "write_term", ar); } } wopts.var_names = have_var_names ? &vnames : NULL; pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (wopts.fullstop) { sbuf_append_char(&sb, '.'); } if (wopts.nl) { sbuf_append_char(&sb, '\n'); } if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); write_var_name_map_free(&vnames); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if ((!strcmp(fn, "select1") || !strcmp(fn, "select_") || !strcmp(fn, "select")) && (ar == 3) && goal->v.str.args) { pl_term *list0 = deref_term_wam(goal->v.str.args[1]); if (!list0) { return cut_none(); } if (term_is_nil(list0)) { return cut_none(); } if (!term_is_list_pair(list0)) { pl_term *rel = build_select_relational_rt(rt_ctrl, dbg_dat_ptr, fn, goal->v.str.args[0], goal->v.str.args[1], goal->v.str.args[2]); const ULO rest = goal_count ? (goal_count - 1) : 0; const ULO new_goal_count = 1 + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } new_goals[0] = rel; for (ULO i = 1; i < goal_count; i++) { new_goals[i] = goals[i]; } return solve_goals_wam_cb(prog, q, new_goals, new_goal_count, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } const CHR *cons_functor = list0->v.str.functor; pl_list_cycle_info cycle = {0}; const bool has_cycle = list_pair_cycle_info_wam(list0, &cycle); const ULO cycle_start = has_cycle ? cycle.prefix_len : 0; const ULO cycle_end = has_cycle ? (cycle.prefix_len + cycle.cycle_len) : 0; if (has_cycle && g_unify_occurs_check) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } // OR-par split: for large enough lists, treat select1/3 as a high-quality choicepoint for work-stealing OR-par. // // This is a key enabler for automatically-parallel search problems (e.g. magic squares) where branching comes // from deep nondet generators rather than many predicate clauses. // // Performance note: counting the list length requires a full traversal. We avoid this work unless OR-par is // actually possible (enabled + nesting allows it + worker budget available). bool can_orpar = prog && g_par_state && (g_table_state == NULL) && ((SLO)g_orpar_level <= prog->flag_parallel_or_nesting) && prog->flag_parallel_or && (prog->flag_parallel_max_depth > 0) && !stop_at_first; if (can_orpar && g_par_budget) { if (atomic_load_explicit(g_par_budget, memory_order_relaxed) <= 0) { can_orpar = false; } } if (has_cycle) { can_orpar = false; } ULO alt_count = 0; if (can_orpar) { pl_term *lc = list0; while (1) { lc = deref_term_wam(lc); if (!lc) { return cut_none(); } if (term_is_nil(lc)) { break; } if (!term_is_list_pair(lc)) { break; } alt_count++; lc = lc->v.str.args[1]; } } const bool par_or = can_orpar && (alt_count >= (ULO)FLOWLOG_SELECT1_ORPAR_DEEP_THRESHOLD); if (par_or && (alt_count >= FLOWLOG_ORPAR_MIN_ALT_THRESHOLD)) { const uint64_t orpar_t0 = flowlog_monotonic_ns(); const CHR *pred = "select1"; const ULO pred_arity = 3; ULO worker_count = (ULO)g_par_state->max_threads; if (worker_count < 2) { worker_count = 2; } if (worker_count > alt_count) { worker_count = alt_count; } int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } if (worker_count >= 2) { const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const pl_wam_cont *cont_copy = wam_cont_clone(cont, rt_ctrl, dbg_dat_ptr); ULO chunk_count = worker_count * 128; const ULO chunk_cap = 16384; if (chunk_count > chunk_cap) { chunk_count = chunk_cap; } if (chunk_count > alt_count) { chunk_count = alt_count; } if (!chunk_count) { chunk_count = alt_count; } flowlog_debug_orpar_log_start(pred, pred_arity, alt_count, worker_count, chunk_count, depth, stop_at_first); pl_or_job *workers = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*workers) * worker_count, dbg_dat_ptr); memset(workers, 0, sizeof(*workers) * worker_count); pl_or_job *chunks = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*chunks) * chunk_count, dbg_dat_ptr); memset(chunks, 0, sizeof(*chunks) * chunk_count); pl_or_work *work = (pl_or_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->count = worker_count; work->jobs = workers; work->chunk_count = chunk_count; work->chunks = chunks; work->unordered = (prog->flag_parallel_or_order == PL_OR_UNORDERED); atomic_init(&work->next_chunk, 0); atomic_init(&work->commit_chunk, 0); atomic_init(&work->max_chunk, (unsigned long)(chunk_count ? (chunk_count - 1) : 0)); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; atomic_init(&work->budget_returned, 0); work->budget_total = remote_taken; work->dbg_t0_ns = orpar_t0; atomic_init(&work->dbg_first_cut_chunk, (unsigned long)ULONG_MAX); for (ULO i = 0; i < chunk_count; i++) { const ULO start = (ULO)(((unsigned __int128)i * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); ULO end = (ULO)(((unsigned __int128)(i + 1) * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); if (end > alt_count) { end = alt_count; } chunks[i] = (pl_or_job){ .kind = PL_OR_JOB_WAM_SELECT1_RANGE, .prog = prog, .q = q, .goal = goal, .env_in = NULL, .wam_in = st, .wam_cont = cont_copy, .drop = NULL, .rest_goals = (pl_term *const *)(goals + 1), .rest_count = goal_count ? (goal_count - 1) : 0, .cut_barrier = cut_barrier, .exc_barrier = exc_barrier, .depth = depth, .stop_at_first = stop_at_first, .capture_solution_output = (out != NULL) || (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .capture_solution_spans = (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .on_solution = NULL, .on_solution_ctx = NULL, .wam_on_solution = g_wam_on_solution, .wam_on_solution_ctx = g_wam_on_solution_ctx, .on_solution_safe_temp_release = g_on_solution_safe_temp_release, // Use process-local allocation for query-temporary objects to // reduce shared-memory allocator contention in OR-par workers. .local_alloc_ok = true, .stringify_exceptions = false, .chunk_index = i, .work_done = NULL, .work_cancel = &work->cancel, }; atomic_init(&chunks[i].done, 0); chunks[i].u.select1_range.list0 = list0; chunks[i].u.select1_range.cons_functor = cons_functor; chunks[i].u.select1_range.start = start; chunks[i].u.select1_range.end = end; } for (ULO i = 0; i < worker_count; i++) { workers[i] = (pl_or_job){ .kind = PL_OR_JOB_WORKER, .prog = prog, .work_done = &work->done, .work_cancel = &work->cancel, }; workers[i].u.worker.work = work; workers[i].budget_return = (i == 0) ? 0 : 1; atomic_init(&workers[i].done, 0); } pl_cut_signal ret = cut_none(); bool stopped = false; const ULO started = flowlog_start_or_work(work, 2, rt_ctrl, dbg_dat_ptr); if (g_par_budget && remote_taken && ((int)started < remote_taken)) { par_global_budget_give(g_par_budget, remote_taken - (int)started); remote_taken = (int)started; work->budget_total = remote_taken; } if (!work->unordered) { ULO last_done = 0; for (ULO i = 0; i < chunk_count; i++) { atomic_store(&work->commit_chunk, (unsigned long)i); pl_or_job *j = &chunks[i]; while (!atomic_load(&j->done)) { if (flowlog_cancelled()) { break; } // Help progress work while waiting for ordered chunk i to complete. unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); last_done = i + 1; if (stopped) { break; } } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); if (stopped && (last_done < chunk_count)) { for (ULO i = last_done; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } } else { ULO done_count = 0; ULO scan = 0; pl_or_job *stop_job = NULL; while (done_count < chunk_count) { if (flowlog_cancelled()) { break; } bool progressed = false; for (ULO n = 0; n < chunk_count; n++) { const ULO idx = (scan + n) % chunk_count; pl_or_job *j = &chunks[idx]; const int done = atomic_load(&j->done); if (done != 1) { continue; } done_count++; scan = idx + 1; progressed = true; pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } if (j->sig.cut) { ret = j->sig; stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); atomic_store(&j->done, 2); } if (stopped) { break; } if (progressed) { continue; } if (atomic_load_explicit(&work->cancel, memory_order_relaxed)) { usleep(1000); continue; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); for (ULO i = 0; i < chunk_count; i++) { pl_or_job *j = &chunks[i]; if (j == stop_job) { continue; } if (atomic_load(&j->done) == 2) { continue; } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); } if (stop_job) { pl_or_job_dispose(stop_job, rt_ctrl, dbg_dat_ptr); } } flowlog_debug_orpar_log_stop(pred, pred_arity, alt_count, flowlog_monotonic_ns() - orpar_t0, stopped, atomic_load(&work->cancel) != 0); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return ret; } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } pl_term *prefix[256]; size_t prefix_count = 0; pl_term *cur = list0; ULO idx = 0; pl_list_cycle_guard cg; if (!has_cycle) { list_cycle_guard_init(&cg, cur); } while (1) { const pl_cut_signal lim = flowlog_inference_limit_tick(exc_barrier, rt_ctrl, dbg_dat_ptr); if (lim.except) { return lim; } if (has_cycle && (idx == cycle_end)) { idx = cycle_start; if (prefix_count > cycle_start) { prefix_count = cycle_start; } } cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { return cut_none(); } if (!term_is_list_pair(cur)) { return cut_none(); } pl_term *head = cur->v.str.args[0]; pl_term *tail = cur->v.str.args[1]; if (stop_at_first && *sol_count) { return cut_none(); } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } // Build Rest = Prefix ++ Tail. pl_term *rest = tail; if (prefix_count) { const size_t align = sizeof(void *); const size_t term_bytes = prefix_count * sizeof(pl_term); const size_t term_bytes_aligned = (term_bytes + align - 1) & ~(align - 1); const size_t args_bytes = prefix_count * 2 * sizeof(pl_term *); const size_t total_bytes = term_bytes_aligned + args_bytes; void *mem = pool_alloc(rt_ctrl, (ULO)total_bytes, dbg_dat_ptr); pl_term *terms = (pl_term *)mem; pl_term **args = (pl_term **)((char *)mem + term_bytes_aligned); for (size_t i = prefix_count; i > 0; i--) { const size_t idx = prefix_count - i; pl_term *cons = &terms[idx]; cons->tag = PL_TERM_STRUCT; cons->builtin = 0; cons->reserved16 = 0; cons->v.str.arity = 2; cons->v.str.functor = (CHR *)(cons_functor ? cons_functor : "."); cons->v.str.args = &args[idx * 2]; cons->v.str.args[0] = prefix[i - 1]; cons->v.str.args[1] = rest; rest = cons; } } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], head, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], rest, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (r.except || r.cut) { return r; } if (prefix_count < (sizeof(prefix) / sizeof(prefix[0]))) { prefix[prefix_count++] = head; } else { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } cur = tail; idx++; if (!has_cycle && list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "select1", 3); } } return cut_none(); } if (!strcmp(fn, "keysort") && (ar == 2) && goal->v.str.args) { pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[0], &v, dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st_list == PL_LIST_STATUS_TYPE_ERROR) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[0], &empty, "keysort", 2); } if (v.count) { for (ULO i = 0; i < v.count; i++) { pl_term *t = deref_term_wam(v.items[i]); if (!t) { term_vec_free(&v); return cut_none(); } if (t->tag == PL_TERM_VAR) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if ((t->tag != PL_TERM_STRUCT) || (t->v.str.arity != 2) || strcmp(t->v.str.functor, "-")) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "pair", t, &empty, "keysort", 2); } v.items[i] = t; } // Stable insertion sort by Key (first arg). for (ULO i = 1; i < v.count; i++) { pl_term *pair = v.items[i]; pl_term *key = pair->v.str.args[0]; ULO j = i; while (j > 0) { pl_term *prev = v.items[j - 1]; pl_term *prev_key = prev->v.str.args[0]; if (compare_std_terms_wam(prev_key, key, dbg_dat_ptr) <= 0) { break; } v.items[j] = prev; j--; } v.items[j] = pair; } } // Validate output argument is list/partial list and (if given) a list of pairs. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term_wam(out0); if (!out_term) { term_vec_free(&v); return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", out0, &empty, "keysort", 2); } pl_term *h = NULL; pl_term *tail = NULL; if (!term_list_like_uncons_rt(cur, &h, &tail, rt_ctrl, dbg_dat_ptr) || !h || !tail) { term_vec_free(&v); return cut_none(); } pl_term *e = deref_term_wam(h); if (!e) { term_vec_free(&v); return cut_none(); } if (e->tag != PL_TERM_VAR) { if ((e->tag != PL_TERM_STRUCT) || (e->v.str.arity != 2) || strcmp(e->v.str.functor, "-")) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "pair", e, &empty, "keysort", 2); } } cur = tail; if (list_cycle_guard_step_wam(&cg)) { term_vec_free(&v); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "keysort", 2); } } } pl_term *list = build_list_rt(rt_ctrl, dbg_dat_ptr, v.items, v.count); term_vec_free(&v); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "sort") && (ar == 2) && goal->v.str.args) { pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[0], &v, dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st_list == PL_LIST_STATUS_TYPE_ERROR) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", goal->v.str.args[0], &empty, "sort", 2); } // Validate output argument is list/partial list. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term_wam(out0); if (!out_term) { term_vec_free(&v); return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", out0, &empty, "sort", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { term_vec_free(&v); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "sort", 2); } } } if (v.count) { g_qsort_wam_dbg_dat_ptr = dbg_dat_ptr; qsort(v.items, (size_t)v.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp_wam); g_qsort_wam_dbg_dat_ptr = NULL; } ULO uniq = 0; for (ULO i = 0; i < v.count; i++) { if (!uniq || (compare_std_terms_wam(v.items[i], v.items[uniq - 1], dbg_dat_ptr) != 0)) { v.items[uniq++] = v.items[i]; } } pl_term *list = build_list_rt(rt_ctrl, dbg_dat_ptr, v.items, uniq); term_vec_free(&v); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "msort") && (ar == 2) && goal->v.str.args) { pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[0], &v, dbg_dat_ptr); if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&v); return cut_none(); } if (v.count) { g_qsort_wam_dbg_dat_ptr = dbg_dat_ptr; qsort(v.items, (size_t)v.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp_wam); g_qsort_wam_dbg_dat_ptr = NULL; } pl_term *list = build_list_rt(rt_ctrl, dbg_dat_ptr, v.items, v.count); term_vec_free(&v); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } // Fast pruning helper for search-heavy examples. // // bounds_possible(+SortedInts, +K, +Target) if (!strcmp(fn, "bounds_possible") && (ar == 3) && goal->v.str.args) { pl_term *list0 = deref_term_wam(goal->v.str.args[0]); pl_term *k0 = deref_term_wam(goal->v.str.args[1]); pl_term *t0 = deref_term_wam(goal->v.str.args[2]); if (!list0 || !k0 || !t0) { return cut_none(); } pl_env empty = {0}; if (k0->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", k0, &empty, "bounds_possible", 3); } if (t0->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", t0, &empty, "bounds_possible", 3); } const SLO k = k0->v.int_value; const SLO target = t0->v.int_value; if (k <= 0) { if (target == 0) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (k > 256) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "bounds_possible", 3); } SLO min_sum = 0; SLO last_sum = 0; SLO ring[256]; ULO ring_count = 0; ULO ring_pos = 0; pl_term *cur = list0; ULO count = 0; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, &empty, "bounds_possible", 3); } pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", h, &empty, "bounds_possible", 3); } const SLO v = h->v.int_value; count++; if ((SLO)count <= k) { min_sum += v; } if (ring_count < (ULO)k) { ring[ring_count++] = v; last_sum += v; } else { last_sum -= ring[ring_pos]; ring[ring_pos] = v; last_sum += v; ring_pos++; if (ring_pos >= (ULO)k) { ring_pos = 0; } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "bounds_possible", 3); } } if ((SLO)count < k) { return cut_none(); } const SLO max_sum = last_sum; if (target < min_sum || target > max_sum) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "countall") && (ar == 2) && goal->v.str.args) { pl_term *sub_goal_in = deref_term_wam(goal->v.str.args[0]); if (!sub_goal_in) { return cut_none(); } if (sub_goal_in->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (sub_goal_in->tag != PL_TERM_ATOM && sub_goal_in->tag != PL_TERM_STRUCT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", sub_goal_in, &empty, "call", 1); } pl_term *count_arg = deref_term_wam(goal->v.str.args[1]); if (!count_arg) { return cut_none(); } if (count_arg->tag != PL_TERM_VAR && count_arg->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", count_arg, &empty, "countall", 2); } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_wam_state st2 = {0}; wam_state_clone_into(&st2, st, rt_ctrl, dbg_dat_ptr); ULO inner_sol = 0; int local_barrier = 0; pl_term *sub_goals[1] = {sub_goal_in}; pl_wam_state *saved_wam = g_wam_state; g_wam_state = &st2; pl_cut_signal inner = solve_goals_wam_cb(prog, q, sub_goals, 1, &st2, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, rt_ctrl, dbg_dat_ptr, NULL); g_wam_state = saved_wam; wam_trail_free(&st2.trail); free(st2.scopes); st2.scopes = NULL; st2.scope_count = 0; st2.scope_cap = 0; if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (inner.except) { return inner; } if (inner.cut && (inner.target != &local_barrier)) { return inner; } pl_term *n = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)inner_sol); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], n, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "length") && (ar == 2) && goal->v.str.args) { pl_term *list0 = deref_term_wam(goal->v.str.args[0]); pl_term *len0 = deref_term_wam(goal->v.str.args[1]); if (!list0 || !len0) { return cut_none(); } const bool list_is_var = (list0->tag == PL_TERM_VAR); const bool len_is_var = (len0->tag == PL_TERM_VAR); if (!len_is_var && (len0->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", len0, &empty, "length", 2); } if (!len_is_var && (len0->v.int_value < 0)) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", len0, &empty, "length", 2); } // Generator when both arguments are variables. if (len_is_var && list_is_var) { for (SLO n = 0; !FLOWLOG_DEPTH_LIMIT_EXCEEDED((ULO)n, FLOWLOG_DEPTH_LIMIT); n++) { if (stop_at_first && *sol_count) { return cut_none(); } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); (void)wam_state_push_scope(st, scope, (ULO)n, rt_ctrl, dbg_dat_ptr); pl_term *tail = make_nil_rt(dbg_dat_ptr); for (SLO i = n; i > 0; i--) { pl_term *v = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, scope, (ULO)(i - 1)); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = v; cons->v.str.args[1] = tail; tail = cons; } pl_term *nt = make_int_rt(rt_ctrl, dbg_dat_ptr, n); pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], tail, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], nt, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (r.except || r.cut) { return r; } if (n == LONG_MAX) { break; } } return cut_none(); } // Fixed length: instantiate list when it is a variable. if (!len_is_var && list_is_var) { const SLO target = len0->v.int_value; if (target > (SLO)UINT32_MAX) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); (void)wam_state_push_scope(st, scope, (ULO)target, rt_ctrl, dbg_dat_ptr); pl_term *tail = make_nil_rt(dbg_dat_ptr); for (SLO i = target; i > 0; i--) { pl_term *v = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, scope, (ULO)(i - 1)); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = v; cons->v.str.args[1] = tail; tail = cons; } pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], tail, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } return r; } // Compute list length (List is nonvar). const ULO outer_mark = st->trail.count; pl_scope *tail_scope = NULL; ULO n = 0; pl_term *cur = list0; pl_term *hare = cur; bool hare_ok = true; for (;;) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur)) { break; } if (term_is_pstr_nonempty(cur)) { ULO seg_len = 0; const pl_term *tail = NULL; if (!term_pstr_run_len_and_tail_peeled_const(cur, &seg_len, &tail)) { wam_trail_unwind(&st->trail, outer_mark); if (tail_scope) { wam_state_pop_scope(st, tail_scope); tail_scope = NULL; } return cut_none(); } if (seg_len > (ULO)(LONG_MAX - (SLO)n)) { wam_trail_unwind(&st->trail, outer_mark); if (tail_scope) { wam_state_pop_scope(st, tail_scope); tail_scope = NULL; } return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } n += seg_len; hare_ok = false; cur = (pl_term *)(tail ? tail : make_nil_rt(dbg_dat_ptr)); continue; } if (cur->tag == PL_TERM_VAR) { if (!len_is_var) { // length([a|T], N) with fixed N: instantiate the open tail to a list of // the remaining length. const SLO target = len0->v.int_value; const SLO rem = target - (SLO)n; if (rem < 0) { wam_trail_unwind(&st->trail, outer_mark); return cut_none(); } if (rem > (SLO)UINT32_MAX) { wam_trail_unwind(&st->trail, outer_mark); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } tail_scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*tail_scope), dbg_dat_ptr); memset(tail_scope, 0, sizeof(*tail_scope)); (void)wam_state_push_scope(st, tail_scope, (ULO)rem, rt_ctrl, dbg_dat_ptr); pl_term *tail = make_nil_rt(dbg_dat_ptr); for (SLO i = rem; i > 0; i--) { pl_term *v = make_fresh_var_rt(rt_ctrl, dbg_dat_ptr, tail_scope, (ULO)(i - 1)); pl_term *cons = make_struct_rt(rt_ctrl, dbg_dat_ptr, ".", 2); cons->v.str.args[0] = v; cons->v.str.args[1] = tail; tail = cons; } if (!unify_terms_wam(cur, tail, &st->trail, dbg_dat_ptr)) { wam_trail_unwind(&st->trail, outer_mark); wam_state_pop_scope(st, tail_scope); tail_scope = NULL; return cut_none(); } n = (ULO)target; break; } // Close open tails to [] (ISO behavior for length/2 when N is a variable). pl_term *nil = make_nil_rt(dbg_dat_ptr); if (!unify_terms_wam(cur, nil, &st->trail, dbg_dat_ptr)) { wam_trail_unwind(&st->trail, outer_mark); return cut_none(); } break; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; wam_trail_unwind(&st->trail, outer_mark); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", list0, &empty, "length", 2); } if (n == (ULO)LONG_MAX) { wam_trail_unwind(&st->trail, outer_mark); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } n++; // Floyd cycle detection to avoid infinite loops on cyclic lists. if (hare_ok) { for (int step = 0; step < 2; step++) { hare = deref_term_wam(hare); if (!hare) { hare_ok = false; break; } if (term_is_nil(hare) || (hare->tag == PL_TERM_VAR)) { hare_ok = false; break; } if (!term_is_list_pair(hare)) { // `cur` will throw the correct type error once it reaches this node. hare_ok = false; break; } hare = hare->v.str.args[1]; } if (hare_ok && (hare == cur)) { wam_trail_unwind(&st->trail, outer_mark); return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "length", 2); } } cur = cur->v.str.args[1]; } if (!len_is_var) { // length(List, N) with fixed N. if ((SLO)n != len0->v.int_value) { wam_trail_unwind(&st->trail, outer_mark); if (tail_scope) { wam_state_pop_scope(st, tail_scope); tail_scope = NULL; } return cut_none(); } pl_cut_signal r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); wam_trail_unwind(&st->trail, outer_mark); if (tail_scope) { wam_state_pop_scope(st, tail_scope); tail_scope = NULL; } return r; } // length(List, N) with N var. pl_term *rhs = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)n); pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], rhs, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, outer_mark); return r; } if (!strcmp(fn, "findall") && (ar == 3) && goal->v.str.args) { pl_term *templ_in = goal->v.str.args[0]; pl_term *sub_goal_in = deref_term_wam(goal->v.str.args[1]); if (!templ_in || !sub_goal_in) { return cut_none(); } if (sub_goal_in->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if ((sub_goal_in->tag != PL_TERM_ATOM) && (sub_goal_in->tag != PL_TERM_STRUCT)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", sub_goal_in, &empty, "findall", 3); } const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; // Fast-path: when the template is ground at call time, we can count // solutions and build a repeated list without copying each instance. pl_term *templ_now = deref_term_wam(templ_in); const bool templ_ground = templ_now && term_is_syntactic_ground(templ_now, 0); pl_term *list = NULL; pl_term *sub_goals[1] = {sub_goal_in}; ULO inner_sol = 0; int local_barrier = 0; const ULO inner_mark = st->trail.count; if (templ_ground) { // Ensure nested all-solutions collectors do not see solutions from the // generating goal. g_wam_on_solution = NULL; g_wam_on_solution_ctx = NULL; pl_cut_signal inner = solve_goals_wam_cb(prog, q, sub_goals, 1, st, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, rt_ctrl, dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&st->trail, inner_mark); if (inner.except) { return inner; } list = build_repeat_list_rt(rt_ctrl, dbg_dat_ptr, templ_now, inner_sol); } else { pl_findall_wam_ctx ctx = {.template = templ_in, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr}; findall_wam_vec_init(&ctx.results); // Override nested collector callbacks while enumerating the goal. g_wam_on_solution = findall_wam_on_solution; g_wam_on_solution_ctx = &ctx; pl_cut_signal inner = solve_goals_wam_cb(prog, q, sub_goals, 1, st, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, rt_ctrl, dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&st->trail, inner_mark); if (inner.except) { if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx.alloc, dbg_dat_ptr); } else { temp_alloc_free_all(&ctx.alloc, rt_ctrl, dbg_dat_ptr); } for (ULO i = 0; i < ctx.results.count; i++) { free(ctx.results.items[i].bindings); ctx.results.items[i].bindings = NULL; } findall_wam_vec_free(&ctx.results); return inner; } if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx.alloc, dbg_dat_ptr); } const ULO scope_mark = st->scope_count; // Wire copied variables for each result term into the WAM state so they // behave as regular variables during the continuation. for (ULO ri = 0; ri < ctx.results.count; ri++) { pl_findall_wam_item *it = &ctx.results.items[ri]; if (it->var_count) { pl_wam_cell *cells = wam_state_push_scope(st, it->scope, it->var_count, rt_ctrl, dbg_dat_ptr); if (cells && it->bindings) { for (ULO vi = 0; vi < it->var_count; vi++) { cells[vi].value = it->bindings[vi]; } } } free(it->bindings); it->bindings = NULL; } if (ctx.results.count) { pl_term **elems = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * ctx.results.count, dbg_dat_ptr); for (ULO i = 0; i < ctx.results.count; i++) { elems[i] = ctx.results.items[i].term; } list = build_list_rt(rt_ctrl, dbg_dat_ptr, elems, ctx.results.count); } else { list = make_nil_rt(dbg_dat_ptr); } const ULO outer_mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, outer_mark); st->scope_count = scope_mark; findall_wam_vec_free(&ctx.results); if (!g_temp_alloc) { temp_alloc_free_all(&ctx.alloc, rt_ctrl, dbg_dat_ptr); } return r; } const ULO outer_mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], list, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, outer_mark); return r; } if (!strcmp(fn, "current_op") && (ar == 3) && goal->v.str.args) { const pl_op_overrides *ops = prog ? prog->op_overrides : NULL; for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { const pl_op_decl *base = &PL_OPS[i]; const pl_op_decl *op = base; const pl_op_decl *ov = op_override_find(ops, base->name, base->fix); if (ov) { if (!ov->prec) { continue; // disabled } op = ov; } const CHR *spec = NULL; switch (op->fix) { case PL_OP_INFIX_XFX: spec = "xfx"; break; case PL_OP_INFIX_XFY: spec = "xfy"; break; case PL_OP_INFIX_YFX: spec = "yfx"; break; case PL_OP_PREFIX_FX: spec = "fx"; break; case PL_OP_PREFIX_FY: spec = "fy"; break; case PL_OP_POSTFIX_XF: spec = "xf"; break; case PL_OP_POSTFIX_YF: spec = "yf"; break; } if (!spec) { continue; } if (stop_at_first && *sol_count) { return cut_none(); } pl_term *prec_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)op->prec); pl_term *spec_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, spec); pl_term *name_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, op->name); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], prec_term, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], spec_term, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], name_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } // Enumerate operators introduced via op/3 that are not present in the base table. if (!ops) { return cut_none(); } for (ULO i = 0; i < ops->count; i++) { const pl_op_decl *op = &ops->items[i]; if (!op->prec) { continue; } bool in_base = false; for (ULO j = 0; j < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); j++) { const pl_op_decl *base = &PL_OPS[j]; if (base->fix == op->fix && !strcmp(base->name, op->name)) { in_base = true; break; } } if (in_base) { continue; } const CHR *spec = NULL; switch (op->fix) { case PL_OP_INFIX_XFX: spec = "xfx"; break; case PL_OP_INFIX_XFY: spec = "xfy"; break; case PL_OP_INFIX_YFX: spec = "yfx"; break; case PL_OP_PREFIX_FX: spec = "fx"; break; case PL_OP_PREFIX_FY: spec = "fy"; break; case PL_OP_POSTFIX_XF: spec = "xf"; break; case PL_OP_POSTFIX_YF: spec = "yf"; break; } if (!spec) { continue; } if (stop_at_first && *sol_count) { return cut_none(); } pl_term *prec_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)op->prec); pl_term *spec_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, spec); pl_term *name_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, op->name); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], prec_term, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], spec_term, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], name_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "op") && (ar == 3) && goal->v.str.args) { pl_term *prec_term = deref_term_wam(goal->v.str.args[0]); if (!prec_term) { return cut_none(); } if (prec_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer"); } if (prec_term->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", prec_term, &empty, "op", 3); } const SLO prec_val = prec_term->v.int_value; if (prec_val < 0 || prec_val > 1200) { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "operator_priority", prec_term, &empty, "op", 3); } pl_term *spec_term = deref_term_wam(goal->v.str.args[1]); if (!spec_term) { return cut_none(); } if (spec_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (spec_term->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", spec_term, &empty, "op", 3); } pl_op_fix fix = PL_OP_INFIX_XFX; if (!strcmp(spec_term->v.atom_name, "xfx")) { fix = PL_OP_INFIX_XFX; } else if (!strcmp(spec_term->v.atom_name, "xfy")) { fix = PL_OP_INFIX_XFY; } else if (!strcmp(spec_term->v.atom_name, "yfx")) { fix = PL_OP_INFIX_YFX; } else if (!strcmp(spec_term->v.atom_name, "fx")) { fix = PL_OP_PREFIX_FX; } else if (!strcmp(spec_term->v.atom_name, "fy")) { fix = PL_OP_PREFIX_FY; } else if (!strcmp(spec_term->v.atom_name, "xf")) { fix = PL_OP_POSTFIX_XF; } else if (!strcmp(spec_term->v.atom_name, "yf")) { fix = PL_OP_POSTFIX_YF; } else { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "operator_specifier", spec_term, &empty, "op", 3); } pl_term *ops_term = deref_term_wam(goal->v.str.args[2]); if (!ops_term) { return cut_none(); } if (ops_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list"); } // Match Trealla behaviour: treat [] and {} as operator names (not a list), so // accept list syntax only for non-empty '.'/2 lists. if (ops_term->tag == PL_TERM_ATOM) { const CHR *name = ops_term->v.atom_name; if (!strcmp(name, ",")) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "operator", ops_term, &empty, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "create", "operator", ops_term, &empty, "op", 3); } (void)op_override_set(prog, name, fix, (int)prec_val, rt_ctrl, dbg_dat_ptr); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!term_is_list_pair(ops_term)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", ops_term, &empty, "op", 3); } pl_term *cur = ops_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (term_is_nil(cur)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (term_is_list_pair(cur)) { pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (h->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", h, &empty, "op", 3); } const CHR *name = h->v.atom_name; if (!strcmp(name, ",")) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "operator", h, &empty, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "create", "operator", h, &empty, "op", 3); } (void)op_override_set(prog, name, fix, (int)prec_val, rt_ctrl, dbg_dat_ptr); cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "op", 3); } continue; } // Trealla accepts '.'/2 lists whose tail is an atom and treats that tail // as an additional operator name (e.g. op(500,xfx,[a|b])). if (cur->tag == PL_TERM_ATOM) { const CHR *name = cur->v.atom_name; if (!strcmp(name, ",")) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "operator", cur, &empty, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "create", "operator", cur, &empty, "op", 3); } (void)op_override_set(prog, name, fix, (int)prec_val, rt_ctrl, dbg_dat_ptr); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } // Tail is a variable: insufficiently instantiated; otherwise ignore. if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", ops_term, &empty, "op", 3); } if ((!strcmp(fn, "bagof") || !strcmp(fn, "setof")) && (ar == 3) && goal->v.str.args) { const bool is_setof = !strcmp(fn, "setof"); pl_term *templ_in = goal->v.str.args[0]; if (!templ_in) { return cut_none(); } pl_var_list exist = {0}; var_list_init(&exist); pl_term *goal_core = strip_bagof_existentials_wam(goal->v.str.args[1], &exist, dbg_dat_ptr); if (!goal_core) { var_list_free(&exist); return cut_none(); } pl_term *goal_core_d = deref_term_wam(goal_core); if (!goal_core_d) { var_list_free(&exist); return cut_none(); } if (goal_core_d->tag == PL_TERM_VAR) { var_list_free(&exist); return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if ((goal_core_d->tag != PL_TERM_ATOM) && (goal_core_d->tag != PL_TERM_STRUCT)) { pl_env empty = {0}; var_list_free(&exist); return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", goal_core_d, &empty, fn, 3); } pl_var_stack stv; pl_var_list goal_vars = {0}; pl_var_list templ_vars = {0}; var_stack_init(&stv); var_list_init(&goal_vars); term_collect_vars_wam_tr(goal_core, &stv, &goal_vars, dbg_dat_ptr, 0); var_stack_free(&stv); var_stack_init(&stv); var_list_init(&templ_vars); term_collect_vars_wam_tr(templ_in, &stv, &templ_vars, dbg_dat_ptr, 0); var_stack_free(&stv); pl_term **free_vars = NULL; ULO free_count = 0; if (goal_vars.count) { free_vars = (pl_term **)malloc(sizeof(pl_term *) * goal_vars.count); if (!free_vars) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } } for (ULO i = 0; i < goal_vars.count; i++) { pl_var_key k = goal_vars.items[i].key; if (var_list_contains_key(&templ_vars, k) || var_list_contains_key(&exist, k)) { continue; } free_vars[free_count++] = goal_vars.items[i].term; } pl_term *outer_key = build_list_rt(rt_ctrl, dbg_dat_ptr, free_vars, free_count); const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; pl_bagof_wam_ctx ctx = {.key = outer_key, .template = templ_in, .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr}; bagof_wam_vec_init(&ctx.results); g_wam_on_solution = bagof_wam_on_solution; g_wam_on_solution_ctx = &ctx; pl_term *sub_goals[1] = {goal_core}; ULO inner_sol = 0; int local_barrier = 0; const ULO inner_mark = st->trail.count; pl_cut_signal inner = solve_goals_wam_cb(prog, q, sub_goals, 1, st, &local_barrier, exc_barrier, depth + 1, false, NULL, &inner_sol, rt_ctrl, dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&st->trail, inner_mark); pl_cut_signal result = cut_none(); if (inner.except) { if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx.alloc, dbg_dat_ptr); } else { temp_alloc_free_all(&ctx.alloc, rt_ctrl, dbg_dat_ptr); } for (ULO i = 0; i < ctx.results.count; i++) { free(ctx.results.items[i].bindings); ctx.results.items[i].bindings = NULL; } bagof_wam_vec_free(&ctx.results); free(free_vars); var_list_free(&templ_vars); var_list_free(&goal_vars); var_list_free(&exist); return inner; } if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx.alloc, dbg_dat_ptr); } if (!ctx.results.count) { bagof_wam_vec_free(&ctx.results); if (!g_temp_alloc) { temp_alloc_free_all(&ctx.alloc, rt_ctrl, dbg_dat_ptr); } free(free_vars); var_list_free(&templ_vars); var_list_free(&goal_vars); var_list_free(&exist); return cut_none(); } const ULO scope_mark = st->scope_count; for (ULO ri = 0; ri < ctx.results.count; ri++) { pl_bagof_wam_item *it = &ctx.results.items[ri]; if (it->var_count) { pl_wam_cell *cells = wam_state_push_scope(st, it->scope, it->var_count, rt_ctrl, dbg_dat_ptr); if (cells && it->bindings) { for (ULO vi = 0; vi < it->var_count; vi++) { cells[vi].value = it->bindings[vi]; } } } free(it->bindings); it->bindings = NULL; } pl_solution_group_vec groups = {0}; group_vec_init(&groups); const ULO merge_mark = st->trail.count; for (ULO ri = 0; ri < ctx.results.count; ri++) { pl_bagof_wam_item *it = &ctx.results.items[ri]; if (!it->key || !it->term) { continue; } bool placed = false; for (ULO gi = 0; gi < groups.count; gi++) { pl_solution_group *g = &groups.items[gi]; if (!g->key) { continue; } if (!term_variant_wam(it->key, g->key, dbg_dat_ptr)) { continue; } const ULO key_mark = st->trail.count; if (unify_terms_wam(it->key, g->key, &st->trail, dbg_dat_ptr)) { term_vec_push(&g->templates, dbg_dat_ptr, it->term); placed = true; break; } wam_trail_unwind(&st->trail, key_mark); } if (placed) { continue; } pl_solution_group *g = group_vec_push(&groups, dbg_dat_ptr); g->key = it->key; term_vec_push(&g->templates, dbg_dat_ptr, it->term); } if (groups.count > 1) { const ULO *saved_dbg = g_group_qsort_wam_dbg_dat_ptr; g_group_qsort_wam_dbg_dat_ptr = dbg_dat_ptr; qsort(groups.items, (size_t)groups.count, sizeof(pl_solution_group), qsort_solution_group_cmp_wam); g_group_qsort_wam_dbg_dat_ptr = saved_dbg; } if (is_setof) { for (ULO gi = 0; gi < groups.count; gi++) { pl_solution_group *g = &groups.items[gi]; if (g->templates.count) { const ULO *saved_dbg = g_qsort_wam_dbg_dat_ptr; g_qsort_wam_dbg_dat_ptr = dbg_dat_ptr; qsort(g->templates.items, (size_t)g->templates.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp_wam); g_qsort_wam_dbg_dat_ptr = saved_dbg; } ULO uniq = 0; for (ULO i = 0; i < g->templates.count; i++) { if (!uniq || (compare_std_terms_wam(g->templates.items[i], g->templates.items[uniq - 1], dbg_dat_ptr) != 0)) { g->templates.items[uniq++] = g->templates.items[i]; } } g->templates.count = uniq; } } for (ULO gi = 0; gi < groups.count; gi++) { if (stop_at_first && *sol_count) { break; } pl_solution_group *g = &groups.items[gi]; pl_term *bag_list = build_list_rt(rt_ctrl, dbg_dat_ptr, g->templates.items, g->templates.count); const ULO out_mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], bag_list, &st->trail, dbg_dat_ptr) && unify_terms_wam(outer_key, g->key, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, out_mark); if (r.cut || r.except) { result = r; break; } } group_vec_free(&groups); bagof_wam_vec_free(&ctx.results); if (!g_temp_alloc) { temp_alloc_free_all(&ctx.alloc, rt_ctrl, dbg_dat_ptr); } wam_trail_unwind(&st->trail, merge_mark); st->scope_count = scope_mark; free(free_vars); var_list_free(&templ_vars); var_list_free(&goal_vars); var_list_free(&exist); return result; } if (!strcmp(fn, "current_prolog_flag") && (ar == 2) && goal->v.str.args) { pl_term *flag = deref_term_wam(goal->v.str.args[0]); if (!flag) { return cut_none(); } const pl_unknown_mode unknown_mode = prog ? prog->flag_unknown : PL_UNKNOWN_ERROR; const bool char_conv_on = prog ? prog->flag_char_conversion : false; const bool character_escapes = prog ? prog->flag_character_escapes : true; const bool occurs_check = prog ? prog->flag_occurs_check : false; const bool debug_on = prog ? prog->flag_debug : false; const bool par_or_on = prog ? prog->flag_parallel_or : false; const pl_or_order_mode par_or_order = prog ? prog->flag_parallel_or_order : PL_OR_ORDERED; const bool par_and_on = prog ? prog->flag_parallel_and : false; const SLO par_max_depth = prog ? prog->flag_parallel_max_depth : flowlog_default_parallel_max_depth_auto(); const SLO par_or_nesting = prog ? prog->flag_parallel_or_nesting : (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; const pl_double_quotes_mode dq_mode = prog ? prog->flag_double_quotes : PL_DQ_CHARS; const pl_engine_mode eng_mode = prog ? prog->flag_engine : PL_ENGINE_INTERP; const pl_engine_mode eng_active_mode = g_engine_active; const CHR *unknown_atom = "error"; if (unknown_mode == PL_UNKNOWN_WARNING) { unknown_atom = "warning"; } else if (unknown_mode == PL_UNKNOWN_FAIL) { unknown_atom = "fail"; } const CHR *dq_atom = "codes"; if (dq_mode == PL_DQ_ATOM) { dq_atom = "atom"; } else if (dq_mode == PL_DQ_CHARS) { dq_atom = "chars"; } const CHR *par_or_order_atom = (par_or_order == PL_OR_UNORDERED) ? "unordered" : "ordered"; const bool par_all_on = par_or_on && par_and_on && (par_max_depth > 0); const CHR *par_profile_atom = "custom"; if (!par_or_on && !par_and_on) { par_profile_atom = "off"; } else if (par_all_on) { par_profile_atom = (par_or_order == PL_OR_UNORDERED) ? "fast" : "iso"; } const CHR *engine_atom = "interp"; if (eng_mode == PL_ENGINE_WAM) { engine_atom = "wam"; } else if (eng_mode == PL_ENGINE_WAMVM) { engine_atom = "wamvm"; } const CHR *engine_active_atom = "interp"; if (eng_active_mode == PL_ENGINE_WAM) { engine_active_atom = "wam"; } else if (eng_active_mode == PL_ENGINE_WAMVM) { engine_active_atom = "wamvm"; } if (flag->tag == PL_TERM_VAR) { struct { const CHR *name; pl_term *value; } flags[] = { {"bounded", make_atom_rt(rt_ctrl, dbg_dat_ptr, "false")}, {"max_arity", make_int_rt(rt_ctrl, dbg_dat_ptr, 255)}, {"integer_rounding_function", make_atom_rt(rt_ctrl, dbg_dat_ptr, "toward_zero")}, {"double_quotes", make_atom_rt(rt_ctrl, dbg_dat_ptr, dq_atom)}, {"char_conversion", make_atom_rt(rt_ctrl, dbg_dat_ptr, char_conv_on ? "on" : "off")}, {"character_escapes", make_atom_rt(rt_ctrl, dbg_dat_ptr, character_escapes ? "true" : "false")}, {"occurs_check", make_atom_rt(rt_ctrl, dbg_dat_ptr, occurs_check ? "true" : "false")}, {"debug", make_atom_rt(rt_ctrl, dbg_dat_ptr, debug_on ? "on" : "off")}, {"flowlog_engine", make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_atom)}, {"flowlog_engine_active", make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_active_atom)}, {"flowlog_parallel", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_all_on ? "on" : "off")}, {"flowlog_parallel_profile", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_profile_atom)}, {"flowlog_parallel_or", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_on ? "on" : "off")}, {"flowlog_parallel_or_order", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_order_atom)}, {"flowlog_parallel_and", make_atom_rt(rt_ctrl, dbg_dat_ptr, par_and_on ? "on" : "off")}, {"flowlog_parallel_max_depth", make_int_rt(rt_ctrl, dbg_dat_ptr, par_max_depth)}, {"flowlog_parallel_or_nesting", make_int_rt(rt_ctrl, dbg_dat_ptr, par_or_nesting)}, {"argv", flowlog_build_argv_term(prog, rt_ctrl, dbg_dat_ptr)}, {"unknown", make_atom_rt(rt_ctrl, dbg_dat_ptr, unknown_atom)}, }; for (ULO i = 0; i < (sizeof(flags) / sizeof(flags[0])); i++) { if (stop_at_first && *sol_count) { break; } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); pl_term *name_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, flags[i].name); if (unify_terms_wam(goal->v.str.args[0], name_term, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], flags[i].value, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } return cut_none(); } if (flag->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", flag, &empty, "$legacy_current_prolog_flag", 2); } pl_term *val = NULL; if (!strcmp(flag->v.atom_name, "bounded")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "false"); } else if (!strcmp(flag->v.atom_name, "max_arity")) { val = make_int_rt(rt_ctrl, dbg_dat_ptr, 255); } else if (!strcmp(flag->v.atom_name, "integer_rounding_function")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, "toward_zero"); } else if (!strcmp(flag->v.atom_name, "double_quotes")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, dq_atom); } else if (!strcmp(flag->v.atom_name, "char_conversion")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, char_conv_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "character_escapes")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, character_escapes ? "true" : "false"); } else if (!strcmp(flag->v.atom_name, "occurs_check")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, occurs_check ? "true" : "false"); } else if (!strcmp(flag->v.atom_name, "debug")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, debug_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_engine")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_engine_active")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, engine_active_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_all_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_profile")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_profile_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or_order")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_or_order_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_and")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, par_and_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_max_depth")) { val = make_int_rt(rt_ctrl, dbg_dat_ptr, par_max_depth); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or_nesting")) { val = make_int_rt(rt_ctrl, dbg_dat_ptr, par_or_nesting); } else if (!strcmp(flag->v.atom_name, "argv")) { val = flowlog_build_argv_term(prog, rt_ctrl, dbg_dat_ptr); } else if (!strcmp(flag->v.atom_name, "unknown")) { val = make_atom_rt(rt_ctrl, dbg_dat_ptr, unknown_atom); } else { pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "prolog_flag", flag, &empty, "$legacy_current_prolog_flag", 2); } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], val, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "set_prolog_flag") && (ar == 2) && goal->v.str.args) { // ISO: set_prolog_flag(+Flag, +Value). pl_term *flag = deref_term_wam(goal->v.str.args[0]); pl_term *val = deref_term_wam(goal->v.str.args[1]); if (!flag || !val) { return cut_none(); } if (flag->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom"); } if (flag->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", flag, &empty, "set_prolog_flag", 2); } if (val->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "var"); } const CHR *flag_name = flag->v.atom_name; if (!flag_name) { return cut_none(); } if (!strcmp(flag_name, "unknown")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "error") && strcmp(val->v.atom_name, "warning") && strcmp(val->v.atom_name, "fail"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "unknown"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "error")) { prog->flag_unknown = PL_UNKNOWN_ERROR; } else if (!strcmp(val->v.atom_name, "warning")) { prog->flag_unknown = PL_UNKNOWN_WARNING; } else { prog->flag_unknown = PL_UNKNOWN_FAIL; } } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "occurs_check")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "true") && strcmp(val->v.atom_name, "false"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "occurs_check"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_occurs_check = !strcmp(val->v.atom_name, "true"); g_unify_occurs_check = prog->flag_occurs_check; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "char_conversion")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "char_conversion"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_char_conversion = !strcmp(val->v.atom_name, "on"); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "character_escapes")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "true") && strcmp(val->v.atom_name, "false"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "character_escapes"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_character_escapes = !strcmp(val->v.atom_name, "true"); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "double_quotes")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "atom") && strcmp(val->v.atom_name, "codes") && strcmp(val->v.atom_name, "chars"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "double_quotes"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "atom")) { prog->flag_double_quotes = PL_DQ_ATOM; } else if (!strcmp(val->v.atom_name, "codes")) { prog->flag_double_quotes = PL_DQ_CODES; } else { prog->flag_double_quotes = PL_DQ_CHARS; } } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "debug")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "debug"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_debug = !strcmp(val->v.atom_name, "on"); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_engine")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "interp") && strcmp(val->v.atom_name, "tree") && strcmp(val->v.atom_name, "wam") && strcmp(val->v.atom_name, "wamvm"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_engine"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "wam")) { prog->flag_engine = PL_ENGINE_WAM; } else if (!strcmp(val->v.atom_name, "wamvm")) { prog->flag_engine = PL_ENGINE_WAMVM; } else { prog->flag_engine = PL_ENGINE_INTERP; } } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_parallel")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { const bool on = !strcmp(val->v.atom_name, "on"); if (on) { prog->flag_parallel_or = true; prog->flag_parallel_and = true; if (prog->flag_parallel_or_nesting <= 0) { prog->flag_parallel_or_nesting = 1; } } else { prog->flag_parallel_or = false; prog->flag_parallel_and = false; } } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_parallel_profile")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "off") && strcmp(val->v.atom_name, "iso") && strcmp(val->v.atom_name, "fast"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_profile"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { if (!strcmp(val->v.atom_name, "off")) { prog->flag_parallel_or = false; prog->flag_parallel_and = false; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else if (!strcmp(val->v.atom_name, "iso")) { prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else { prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_UNORDERED; SLO nest = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST; const ULO ncpu = get_n_cpuproc(); if (ncpu >= 128) { nest = 8; } else if (ncpu >= 64) { nest = 4; } else if (ncpu >= 32) { nest = 2; } prog->flag_parallel_or_nesting = nest; } } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_parallel_or")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_or"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_or = !strcmp(val->v.atom_name, "on"); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_parallel_or_order")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "ordered") && strcmp(val->v.atom_name, "unordered"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_or_order"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_or_order = !strcmp(val->v.atom_name, "unordered") ? PL_OR_UNORDERED : PL_OR_ORDERED; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_parallel_and")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_and"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_and = !strcmp(val->v.atom_name, "on"); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_parallel_max_depth")) { if (val->tag != PL_TERM_INT || val->v.int_value < 0) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_max_depth"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_max_depth = val->v.int_value; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "flowlog_parallel_or_nesting")) { if (val->tag != PL_TERM_INT || val->v.int_value < 0) { pl_env empty = {0}; pl_term *cul = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "flowlog_parallel_or_nesting"); cul->v.str.args[1] = val; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (prog) { prog->flag_parallel_or_nesting = val->v.int_value; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(flag_name, "bounded") || !strcmp(flag_name, "max_arity") || !strcmp(flag_name, "integer_rounding_function") || !strcmp(flag_name, "flowlog_engine_active")) { pl_env empty = {0}; return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "flag", flag, &empty, "set_prolog_flag", 2); } // Unrecognized flag: ISO says domain_error(prolog_flag, Flag). pl_env empty = {0}; return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "prolog_flag", flag, &empty, "set_prolog_flag", 2); } if (!strcmp(fn, "char_conversion") && (ar == 2) && goal->v.str.args) { pl_term *in = deref_term_wam(goal->v.str.args[0]); pl_term *outc = deref_term_wam(goal->v.str.args[1]); if (!in || !outc) { return cut_none(); } if (in->tag == PL_TERM_VAR || outc->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character"); } unsigned char in_code = 0; unsigned char out_code = 0; pl_env empty = {0}; if (in->tag == PL_TERM_ATOM) { if (!in->v.atom_name || strlen(in->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, &empty, "char_conversion", 2); } in_code = (unsigned char)in->v.atom_name[0]; } else if (in->tag == PL_TERM_INT) { if (in->v.int_value <= 0 || in->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, &empty, "char_conversion", 2); } in_code = (unsigned char)in->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, &empty, "char_conversion", 2); } if (outc->tag == PL_TERM_ATOM) { if (!outc->v.atom_name || strlen(outc->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, &empty, "char_conversion", 2); } out_code = (unsigned char)outc->v.atom_name[0]; } else if (outc->tag == PL_TERM_INT) { if (outc->v.int_value <= 0 || outc->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, &empty, "char_conversion", 2); } out_code = (unsigned char)outc->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, &empty, "char_conversion", 2); } if (prog) { prog->char_conv_table[in_code] = out_code; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "current_char_conversion") && (ar == 2) && goal->v.str.args) { pl_term *in = deref_term_wam(goal->v.str.args[0]); pl_term *outc = deref_term_wam(goal->v.str.args[1]); if (!in || !outc) { return cut_none(); } const bool in_is_var = (in->tag == PL_TERM_VAR); const bool out_is_var = (outc->tag == PL_TERM_VAR); unsigned char in_code = 0; unsigned char out_code = 0; pl_env empty = {0}; if (!in_is_var) { if (in->tag == PL_TERM_ATOM) { if (!in->v.atom_name || strlen(in->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, &empty, "current_char_conversion", 2); } in_code = (unsigned char)in->v.atom_name[0]; } else if (in->tag == PL_TERM_INT) { if (in->v.int_value <= 0 || in->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, &empty, "current_char_conversion", 2); } in_code = (unsigned char)in->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", in, &empty, "current_char_conversion", 2); } } if (!out_is_var) { if (outc->tag == PL_TERM_ATOM) { if (!outc->v.atom_name || strlen(outc->v.atom_name) != 1) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, &empty, "current_char_conversion", 2); } out_code = (unsigned char)outc->v.atom_name[0]; } else if (outc->tag == PL_TERM_INT) { if (outc->v.int_value <= 0 || outc->v.int_value > 255) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, &empty, "current_char_conversion", 2); } out_code = (unsigned char)outc->v.int_value; } else { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "character", outc, &empty, "current_char_conversion", 2); } } const unsigned char *tbl = prog ? prog->char_conv_table : NULL; if (!in_is_var) { const unsigned char mapped = tbl ? tbl[in_code] : in_code; if (!out_is_var) { if (mapped != out_code) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } CHR tmp[2] = {(CHR)mapped, '\0'}; pl_term *mapped_atom = make_atom_rt(rt_ctrl, dbg_dat_ptr, tmp); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], mapped_atom, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } for (unsigned int c = 1; c <= 255; c++) { if (stop_at_first && *sol_count) { break; } const unsigned char mapped = tbl ? tbl[c] : (unsigned char)c; if (!out_is_var && (mapped != out_code)) { continue; } CHR in_tmp[2] = {(CHR)c, '\0'}; CHR out_tmp[2] = {(CHR)mapped, '\0'}; pl_term *in_atom = make_atom_rt(rt_ctrl, dbg_dat_ptr, in_tmp); pl_term *out_atom = make_atom_rt(rt_ctrl, dbg_dat_ptr, out_tmp); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], in_atom, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], out_atom, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "dynamic") && (ar == 1) && goal->v.str.args) { pl_term *pis = deref_term_wam(goal->v.str.args[0]); if (!pis) { return cut_none(); } if (pis->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "dynamic", 1); } if (term_is_nil(pis)) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } const bool list_mode = term_is_list_pair(pis); const pl_term *cur = pis; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { const pl_term *pi = NULL; if (list_mode) { if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "list", pis, &empty, "dynamic", 1); } pi = deref_term_wam(cur->v.str.args[0]); cur = deref_term_wam(cur->v.str.args[1]); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "term", "dynamic", 1); } } else { pi = deref_term_wam((pl_term *)cur); cur = NULL; } if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "dynamic", 1); } if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", (pl_term *)pi, &empty, "dynamic", 1); } pl_term *name_term = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name_term || !arity_term) { return cut_none(); } if (name_term->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "dynamic", 1); } pl_env empty = {0}; if (name_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name_term, &empty, "dynamic", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, &empty, "dynamic", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "dynamic", 1); } if (arity_val > 1024) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "dynamic", 1); } const CHR *pred_name = name_term->v.atom_name; const ULO pred_arity = (ULO)arity_val; if (builtin_pred_defined(pred_name, pred_arity)) { pl_term *pi_term = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi_term, &empty, "dynamic", 1); } prog_dyn_pred_add(prog, pred_name, pred_arity, rt_ctrl, dbg_dat_ptr); if (!list_mode) { break; } } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "current_rule") && (ar == 1) && goal->v.str.args) { pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "structure"); } if (pi->tag != PL_TERM_STRUCT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "structure", pi, &empty, "current_rule", 1); } if (pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_rule", 1); } pl_term *name = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name || !arity_term) { return cut_none(); } pl_env empty = {0}; if (name->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", pi, &empty, "current_rule", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", pi, &empty, "current_rule", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0 || arity_val > 1024) { return cut_none(); } const CHR *pred_name = name->v.atom_name; const ULO pred_arity = (ULO)arity_val; bool dyn = false; const bool defined = builtin_pred_defined(pred_name, pred_arity) || prog_pred_defined(prog, pred_name, pred_arity, &dyn); if (!defined) { return cut_none(); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "flowlog_cpuproc_id") && (ar == 1) && goal->v.str.args) { const SLO id = (SLO)get_id_cpuproc_fast(rt_ctrl); pl_term *id_term = make_int_rt(rt_ctrl, dbg_dat_ptr, id); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], id_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_n_cpuproc") && (ar == 1) && goal->v.str.args) { const SLO n = (SLO)get_n_cpuproc(); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, n); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], n_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_in_cpuproc") && (ar == 1) && goal->v.str.args) { pl_term *t_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, am_I_in_the_CPUPROC_module() ? "true" : "false"); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], t_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_taskjob_id") && (ar == 1) && goal->v.str.args) { const SLO id = (SLO)get_id_taskjob_fast(rt_ctrl); pl_term *id_term = make_int_rt(rt_ctrl, dbg_dat_ptr, id); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], id_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_n_taskjob") && (ar == 1) && goal->v.str.args) { const SLO n = (SLO)get_n_taskjob(); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, n); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], n_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_last_tc_cp_mask") && (ar == 1) && goal->v.str.args) { pl_term *m_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_cp_mask); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], m_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_last_tc_cp_count") && (ar == 1) && goal->v.str.args) { const unsigned long long m = (unsigned long long)g_last_tc_cp_mask; const SLO n = (SLO)__builtin_popcountll(m); pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, n); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], n_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_last_tc_worker_count") && (ar == 1) && goal->v.str.args) { pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_worker_count); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], n_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_last_tc_start_ok") && (ar == 1) && goal->v.str.args) { pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_start_ok); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], n_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_last_tc_start_error_code") && (ar == 1) && goal->v.str.args) { pl_term *n_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)g_last_tc_start_err_code); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], n_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_last_tc_start_error_text") && (ar == 1) && goal->v.str.args) { pl_term *t_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, g_last_tc_start_err_text); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], t_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_db_epochs") && (ar == 2) && goal->v.str.args) { if (!prog) { return cut_none(); } const unsigned long clause_epoch = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long index_epoch = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); pl_term *cl_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)clause_epoch); pl_term *ix_term = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)index_epoch); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], cl_term, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], ix_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_and_safe") && (ar == 2) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, &empty, "flowlog_and_safe", 2); } pl_term *name = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } pl_env empty = {0}; if (name->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name, &empty, "flowlog_and_safe", 2); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, &empty, "flowlog_and_safe", 2); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "flowlog_and_safe", 2); } prog_par_and_safety_ensure(prog, rt_ctrl, dbg_dat_ptr); bool safe = false; if (prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, name->v.atom_name, (ULO)arity_val); safe = e && e->and_safe; } pl_term *safe_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, safe ? "true" : "false"); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], safe_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "flowlog_and_safe_goal") && (ar == 2) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *g0 = deref_term_wam(goal->v.str.args[0]); if (!g0) { return cut_none(); } if (g0->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable"); } if (g0->tag != PL_TERM_ATOM && g0->tag != PL_TERM_STRUCT) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", g0, &empty, "flowlog_and_safe_goal", 2); } const bool safe = par_and_goal_is_safe_test_wam(prog, g0, rt_ctrl, dbg_dat_ptr); pl_term *safe_term = make_atom_rt(rt_ctrl, dbg_dat_ptr, safe ? "true" : "false"); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], safe_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } if (!strcmp(fn, "listing") && (ar == 1) && goal->v.str.args) { pl_term *spec0 = deref_term_wam(goal->v.str.args[0]); if (!spec0) { return cut_none(); } if (spec0->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "listing", 1); } pl_term *spec = spec0; if (spec->tag == PL_TERM_STRUCT && spec->v.str.arity == 2 && !strcmp(spec->v.str.functor, ":")) { spec = deref_term_wam(spec->v.str.args[1]); if (!spec) { return cut_none(); } } const CHR *want_name = NULL; bool any_arity = false; ULO want_arity = 0; if (spec->tag == PL_TERM_ATOM) { want_name = spec->v.atom_name; any_arity = true; } else if (spec->tag == PL_TERM_STRUCT && spec->v.str.arity == 2 && !strcmp(spec->v.str.functor, "/")) { pl_term *name_term = deref_term_wam(spec->v.str.args[0]); pl_term *arity_term = deref_term_wam(spec->v.str.args[1]); if (!name_term || !arity_term) { return cut_none(); } if (name_term->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "listing", 1); } pl_env empty = {0}; if (name_term->tag != PL_TERM_ATOM || arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", spec, &empty, "listing", 1); } if (arity_term->v.int_value < 0 || arity_term->v.int_value > 1024) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", spec, &empty, "listing", 1); } want_name = name_term->v.atom_name; want_arity = (ULO)arity_term->v.int_value; any_arity = false; } else if (spec->tag == PL_TERM_STRUCT) { want_name = spec->v.str.functor; want_arity = spec->v.str.arity; any_arity = false; } else { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", spec, &empty, "listing", 1); } streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return cut_none(); } if (!s->writable) { pl_env empty = {0}; pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "listing", 1); } if (s->binary) { pl_env empty = {0}; pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "listing", 1); } const pl_clause **snap = NULL; ULO snap_count = 0; if (prog && prog->clauses && prog->clause_count) { prog_db_rlock(prog); snap = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(*snap) * prog->clause_count, dbg_dat_ptr); for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *hn = NULL; ULO ha = 0; if (h->tag == PL_TERM_ATOM) { hn = h->v.atom_name; ha = 0; } else if (h->tag == PL_TERM_STRUCT) { hn = h->v.str.functor; ha = h->v.str.arity; } else { continue; } if (!hn || strcmp(hn, want_name) || (!any_arity && (ha != want_arity))) { continue; } snap[snap_count++] = cl; } prog_db_runlock(prog); } for (ULO i = 0; i < snap_count; i++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = snap[i]; if (!cl || !cl->head) { continue; } pl_temp_mark m = {0}; const bool release_temp = (g_temp_alloc != NULL); if (release_temp) { m = temp_alloc_mark(g_temp_alloc); } pl_term *t = cl->head; if (cl->body_count && cl->body) { pl_term **body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = cl->body[bi + 1]; } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); pl_term *rule = make_struct_rt(rt_ctrl, dbg_dat_ptr, ":-", 2); rule->v.str.args[0] = cl->head; rule->v.str.args[1] = body_term; t = rule; } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, t, cl->env, &wopts, &sb, dbg_dat_ptr); sbuf_append_char(&sb, '.'); sbuf_append_char(&sb, '\n'); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); if (release_temp) { temp_alloc_release(g_temp_alloc, m, rt_ctrl, dbg_dat_ptr); } } if (id != 1) { (void)fflush(s->fp); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } // Dynamic database predicates (ISO core). if ((!strcmp(fn, "asserta") || !strcmp(fn, "assertz") || !strcmp(fn, "assert")) && (ar == 1) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *clause_in = deref_term_wam(goal->v.str.args[0]); if (!clause_in) { return cut_none(); } if (clause_in->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 1); } pl_term *head_in = clause_in; pl_term *body_in = NULL; if (clause_in->tag == PL_TERM_STRUCT && clause_in->v.str.arity == 2 && !strcmp(clause_in->v.str.functor, ":-")) { head_in = deref_term_wam(clause_in->v.str.args[0]); body_in = deref_term_wam(clause_in->v.str.args[1]); } if (!head_in) { return cut_none(); } if (head_in->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, fn, 1); } pl_env empty = {0}; if (head_in->tag != PL_TERM_ATOM && head_in->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", head_in, &empty, fn, 1); } const CHR *target_name = (head_in->tag == PL_TERM_ATOM) ? head_in->v.atom_name : head_in->v.str.functor; const ULO target_arity = (head_in->tag == PL_TERM_ATOM) ? 0 : head_in->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, &empty, fn, 1); } bool dyn = false; const bool defined = prog_pred_defined(prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, &empty, fn, 1); } pl_term **body0 = NULL; ULO body_count = 0; ULO body_cap = 0; if (body_in) { pl_term *bd = deref_term_wam(body_in); const bool is_true = bd && (bd->tag == PL_TERM_ATOM) && bd->v.atom_name && !strcmp(bd->v.atom_name, "true"); if (!is_true) { pl_parse tmp = {0}; tmp.rt_ctrl = rt_ctrl; tmp.dbg_dat_ptr = dbg_dat_ptr; flatten_conjunction_goals(&tmp, body_in, &body0, &body_count, &body_cap); if (body_count == 1) { pl_term *only = deref_term_wam(body0[0]); if (only && (only->tag == PL_TERM_ATOM) && only->v.atom_name && !strcmp(only->v.atom_name, "true")) { body_count = 0; } } } } for (ULO i = 0; i < body_count; i++) { pl_term *bad = find_noncallable_goal_wam(body0[i], 0); if (bad) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", bad, &empty, fn, 1); } } // Dynamic database updates are permanent side-effects: allocate their clause/term structures outside of the query // temporary allocator so they survive backtracking and long-running loops (e.g. ISO test harness). pl_temp_alloc *saved_tmp = temp_alloc_suspend(); pl_clause *cl = (pl_clause *)pool_alloc(rt_ctrl, sizeof(*cl), dbg_dat_ptr); memset(cl, 0, sizeof(*cl)); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); cl->scope = scope; pl_env *cl_env = (pl_env *)pool_alloc(rt_ctrl, sizeof(*cl_env), dbg_dat_ptr); memset(cl_env, 0, sizeof(*cl_env)); cl->env = cl_env; pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = rt_ctrl; cctx.dbg_dat_ptr = dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); cl->head = copy_term_wam_tr(head_in, &cctx, 0); cl->body_count = body_count; if (body_count) { cl->body = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * (body_count + 1), dbg_dat_ptr); cl->body[0] = NULL; for (ULO i = 0; i < body_count; i++) { cl->body[i + 1] = copy_term_wam_tr(body0[i], &cctx, 0); } } cl->var_count = cctx.map.next_var_id; const ULO nvars = cctx.map.next_var_id; if (cctx.bindings && nvars) { for (ULO i = 0; i < nvars && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { env_bind(cl_env, rt_ctrl, dbg_dat_ptr, scope, i, cctx.bindings[i]); } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; clause_compute_tpl_sizes(cl); if (prog && cl->head) { const CHR *pred_name = NULL; ULO pred_arity = 0; if (cl->head->tag == PL_TERM_ATOM) { pred_name = cl->head->v.atom_name; pred_arity = 0; } else if (cl->head->tag == PL_TERM_STRUCT) { pred_name = cl->head->v.str.functor; pred_arity = cl->head->v.str.arity; } if (pred_name) { prog_dyn_pred_add(prog, pred_name, pred_arity, rt_ctrl, dbg_dat_ptr); } } const bool at_front = !strcmp(fn, "asserta"); prog_insert_clause(prog, cl, at_front, rt_ctrl, dbg_dat_ptr); temp_alloc_resume(saved_tmp); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "retract") && (ar == 1) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *pat = deref_term_wam(goal->v.str.args[0]); if (!pat) { return cut_none(); } if (pat->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retract", 1); } pl_term *pat_head = pat; pl_term *pat_body = NULL; const bool pat_is_rule = pat->tag == PL_TERM_STRUCT && pat->v.str.arity == 2 && !strcmp(pat->v.str.functor, ":-"); if (pat_is_rule) { pat_head = deref_term_wam(pat->v.str.args[0]); pat_body = deref_term_wam(pat->v.str.args[1]); } if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retract", 1); } pl_env empty = {0}; if (pat_head->tag != PL_TERM_ATOM && pat_head->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", pat_head, &empty, "retract", 1); } const CHR *target_name = (pat_head->tag == PL_TERM_ATOM) ? pat_head->v.atom_name : pat_head->v.str.functor; const ULO target_arity = (pat_head->tag == PL_TERM_ATOM) ? 0 : pat_head->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retract", 1); } bool dyn = false; const bool defined = prog_pred_defined(prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retract", 1); } if (!defined) { return cut_none(); } ULO snap_count = 0; prog_db_rlock(prog); snap_count = prog->clause_count; prog_db_runlock(prog); for (ULO i = 1; i <= snap_count; i++) { pl_clause *cl = NULL; prog_db_rlock(prog); if (prog->clauses && (i <= prog->clause_count)) { cl = prog->clauses[i]; } prog_db_runlock(prog); if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, target_name) || (h_arity != target_arity)) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(st, scope, cl->var_count, rt_ctrl, dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_term **body_goals = NULL; if (cl->body_count) { body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = clone_term_with_scope_arena(cl->body[bi + 1], cl->scope, scope, &arena, dbg_dat_ptr, 0); } } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); body_term = wrap_var_goals_rt(body_term, rt_ctrl, dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st->trail, rt_ctrl, dbg_dat_ptr); bool ok = false; if (pat_is_rule) { ok = unify_terms_wam(pat_head, head, &st->trail, dbg_dat_ptr) && unify_terms_wam(pat_body, body_term, &st->trail, dbg_dat_ptr); } else { if (!(body_term && (body_term->tag == PL_TERM_ATOM) && body_term->v.atom_name && !strcmp(body_term->v.atom_name, "true"))) { ok = false; } else { ok = unify_terms_wam(pat_head, head, &st->trail, dbg_dat_ptr); } } pl_cut_signal r = cut_none(); if (ok) { // Permanent side-effect: once a clause is retracted, it stays retracted even if we backtrack. prog_db_wlock(prog); if (prog->clauses && (i <= prog->clause_count)) { prog->clauses[i] = NULL; } prog_index_invalidate(prog); prog_db_wunlock(prog); r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "retractall") && (ar == 1) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *pat_head = deref_term_wam(goal->v.str.args[0]); if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retractall", 1); } if (pat_head->tag == PL_TERM_STRUCT && pat_head->v.str.arity == 2 && !strcmp(pat_head->v.str.functor, ":-")) { pat_head = deref_term_wam(pat_head->v.str.args[0]); } if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(exc_barrier, rt_ctrl, dbg_dat_ptr, "retractall", 1); } pl_env empty = {0}; if (pat_head->tag != PL_TERM_ATOM && pat_head->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", pat_head, &empty, "retractall", 1); } const CHR *target_name = (pat_head->tag == PL_TERM_ATOM) ? pat_head->v.atom_name : pat_head->v.str.functor; const ULO target_arity = (pat_head->tag == PL_TERM_ATOM) ? 0 : pat_head->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retractall", 1); } bool dyn = false; const bool defined = prog_pred_defined(prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, target_name, target_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retractall", 1); } ULO snap_count = 0; prog_db_rlock(prog); snap_count = prog->clause_count; prog_db_runlock(prog); bool changed = false; if (defined && prog->clauses && snap_count) { for (ULO i = 1; i <= snap_count; i++) { pl_clause *cl = NULL; prog_db_rlock(prog); if (prog->clauses && (i <= prog->clause_count)) { cl = prog->clauses[i]; } prog_db_runlock(prog); if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, target_name) || (h_arity != target_arity)) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(st, scope, cl->var_count, rt_ctrl, dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st->trail, rt_ctrl, dbg_dat_ptr); const bool match = unify_terms_wam(pat_head, head, &st->trail, dbg_dat_ptr); wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (!match) { continue; } prog_db_wlock(prog); if (prog->clauses && (i <= prog->clause_count)) { prog->clauses[i] = NULL; } if (!changed) { prog_index_invalidate(prog); changed = true; } prog_db_wunlock(prog); } } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "abolish") && (ar == 1) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } pl_env empty = {0}; if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, &empty, "abolish", 1); } pl_term *name = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator"); } if (name->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "atom", name, &empty, "abolish", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "integer", arity_term, &empty, "abolish", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "abolish", 1); } const SLO max_arity = 255; if (arity_val > max_arity) { return throw_representation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "max_arity", "abolish", 1); } bool dyn = false; const bool builtin = builtin_pred_defined(name->v.atom_name, (ULO)arity_val); const bool defined = prog_pred_defined(prog, name->v.atom_name, (ULO)arity_val, &dyn); if (builtin || (defined && !dyn)) { return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "abolish", 1); } ULO snap_count = 0; prog_db_rlock(prog); snap_count = prog->clause_count; prog_db_runlock(prog); bool changed = false; if (prog->clauses && snap_count) { for (ULO i = 1; i <= snap_count; i++) { pl_clause *cl = NULL; prog_db_rlock(prog); if (prog->clauses && (i <= prog->clause_count)) { cl = prog->clauses[i]; } prog_db_runlock(prog); if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *fn_name = NULL; ULO fn_arity = 0; if (h->tag == PL_TERM_ATOM) { fn_name = h->v.atom_name; fn_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { fn_name = h->v.str.functor; fn_arity = h->v.str.arity; } else { continue; } if (!fn_name || strcmp(fn_name, name->v.atom_name) || (fn_arity != (ULO)arity_val)) { continue; } prog_db_wlock(prog); if (prog->clauses && (i <= prog->clause_count)) { prog->clauses[i] = NULL; } if (!changed) { prog_index_invalidate(prog); changed = true; } prog_db_wunlock(prog); } } prog_dyn_pred_remove(prog, name->v.atom_name, (ULO)arity_val); return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(fn, "clause") && (ar == 2) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *head_pat = deref_term_wam(goal->v.str.args[0]); pl_term *body_pat = deref_term_wam(goal->v.str.args[1]); if (!head_pat || !body_pat) { return cut_none(); } if (head_pat->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_env empty = {0}; if (head_pat->tag != PL_TERM_ATOM && head_pat->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", head_pat, &empty, "clause", 2); } if (body_pat->tag != PL_TERM_VAR && body_pat->tag != PL_TERM_ATOM && body_pat->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", body_pat, &empty, "clause", 2); } const CHR *pred_name = (head_pat->tag == PL_TERM_ATOM) ? head_pat->v.atom_name : head_pat->v.str.functor; const ULO pred_arity = (head_pat->tag == PL_TERM_ATOM) ? 0 : head_pat->v.str.arity; if (builtin_pred_defined(pred_name, pred_arity)) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "access", "private_procedure", pi, &empty, "clause", 2); } bool dyn = false; if (!prog_pred_defined(prog, pred_name, pred_arity, &dyn)) { return cut_none(); } if (!dyn) { pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "access", "private_procedure", pi, &empty, "clause", 2); } ULO snap_count = 0; prog_db_rlock(prog); snap_count = prog->clause_count; prog_db_runlock(prog); if (!prog->clauses || !snap_count) { return cut_none(); } for (ULO i = 1; i <= snap_count; i++) { pl_clause *cl = NULL; prog_db_rlock(prog); if (prog->clauses && (i <= prog->clause_count)) { cl = prog->clauses[i]; } prog_db_runlock(prog); if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, pred_name) || (h_arity != pred_arity)) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(st, scope, cl->var_count, rt_ctrl, dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_term **body_goals = NULL; if (cl->body_count) { body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = clone_term_with_scope_arena(cl->body[bi + 1], cl->scope, scope, &arena, dbg_dat_ptr, 0); } } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); body_term = wrap_var_goals_rt(body_term, rt_ctrl, dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st->trail, rt_ctrl, dbg_dat_ptr); pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], head, &st->trail, dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], body_term, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "current_predicate") && (ar == 1) && goal->v.str.args) { if (!prog) { return cut_none(); } pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag != PL_TERM_VAR) { if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } pl_term *name_term = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name_term || !arity_term) { return cut_none(); } pl_env empty = {0}; if (name_term->tag != PL_TERM_VAR && name_term->tag != PL_TERM_ATOM) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } if (arity_term->tag != PL_TERM_VAR) { if (arity_term->tag != PL_TERM_INT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } if (arity_term->v.int_value < 0) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } } } typedef struct { const CHR *name; ULO arity; } pl_pi; ULO cap = 1; cap += prog->clause_count; cap += prog->fact_count; cap += prog->dyn_pred_count; pl_pi *seen = (pl_pi *)pool_alloc(rt_ctrl, sizeof(*seen) * cap, dbg_dat_ptr); ULO seen_count = 0; if (prog->clauses && prog->clause_count) { for (ULO i = 1; i <= prog->clause_count; i++) { pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { continue; } if (!pred_name) { continue; } bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } if (prog->facts && prog->fact_count) { for (ULO i = 1; i <= prog->fact_count; i++) { const pl_term *h = prog->facts[i]; if (!h) { continue; } const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { continue; } if (!pred_name) { continue; } bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } if (prog->dyn_preds && prog->dyn_pred_count) { for (ULO i = 1; i <= prog->dyn_pred_count; i++) { const pl_dyn_pred *dp = &prog->dyn_preds[i]; if (!dp || !dp->name) { continue; } const CHR *pred_name = dp->name; const ULO pred_arity = dp->arity; bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } for (ULO i = 0; i < seen_count; i++) { if (stop_at_first && *sol_count) { break; } pl_term *ind = make_struct_rt(rt_ctrl, dbg_dat_ptr, "/", 2); ind->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, seen[i].name); ind->v.str.args[1] = make_int_rt(rt_ctrl, dbg_dat_ptr, (SLO)seen[i].arity); const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], ind, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } return cut_none(); } if (!strcmp(fn, "predicate_property") && (ar == 2) && goal->v.str.args) { pl_term *callable = deref_term_wam(goal->v.str.args[0]); if (!callable) { return cut_none(); } if (callable->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_env empty = {0}; if (callable->tag != PL_TERM_ATOM && callable->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", callable, &empty, "predicate_property", 2); } pl_term *base = callable; if (base->tag == PL_TERM_STRUCT && base->v.str.arity == 2 && !strcmp(base->v.str.functor, ":")) { base = deref_term_wam(base->v.str.args[1]); } if (!base) { return cut_none(); } if (base->tag != PL_TERM_ATOM && base->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", base, &empty, "predicate_property", 2); } const CHR *pred_name = (base->tag == PL_TERM_ATOM) ? base->v.atom_name : base->v.str.functor; const ULO pred_arity = (base->tag == PL_TERM_ATOM) ? 0 : base->v.str.arity; bool dyn = false; const bool is_builtin = builtin_pred_defined(pred_name, pred_arity); const bool is_user = prog_pred_defined(prog, pred_name, pred_arity, &dyn); if (!is_builtin && !is_user) { return cut_none(); } pl_term *prop = deref_term_wam(goal->v.str.args[1]); if (!prop) { return cut_none(); } if (prop->tag != PL_TERM_VAR) { const bool ok_atom = prop->tag == PL_TERM_ATOM && (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static") || !strcmp(prop->v.atom_name, "dynamic")); const bool ok_template = prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 1 && !strcmp(prop->v.str.functor, "template"); if (!ok_atom && !ok_template) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "predicate_property", prop, &empty, "$legacy_predicate_property", 2); } } const bool is_dynamic = is_user && dyn; const bool is_static = is_builtin || (is_user && !dyn); if (prop->tag == PL_TERM_VAR) { if (is_builtin && pred_arity == 0 && (!strcmp(pred_name, "true") || !strcmp(pred_name, "!") || !strcmp(pred_name, "fail") || !strcmp(pred_name, "false"))) { const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "choice_construct"), &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } if (is_builtin) { const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "built_in"), &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } if (is_static) { const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "static"), &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } if (is_dynamic) { const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "dynamic"), &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } if (is_builtin) { // Trealla reports iso for built-ins, but does not accept it as an input property. const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], make_atom_rt(rt_ctrl, dbg_dat_ptr, "iso"), &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } // Minimal templates for a few ISO predicates. if (!strcmp(pred_name, "write") && (pred_arity == 1 || pred_arity == 2)) { pl_term *templ = make_struct_rt(rt_ctrl, dbg_dat_ptr, "write", pred_arity); if (pred_arity == 1) { pl_term *m = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m; } else { pl_term *m1 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m1->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "stream"); pl_term *m2 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m2->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m1; templ->v.str.args[1] = m2; } pl_term *pt = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 1); pt->v.str.args[0] = templ; const ULO mark2 = st->trail.count; pl_cut_signal r2 = cut_none(); if (unify_terms_wam(goal->v.str.args[1], pt, &st->trail, dbg_dat_ptr)) { r2 = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark2); if (r2.cut || r2.except) { return r2; } } } return cut_none(); } if (prop->tag == PL_TERM_ATOM) { if (!strcmp(prop->v.atom_name, "built_in")) { if (is_builtin) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(prop->v.atom_name, "static")) { if (is_static) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } if (!strcmp(prop->v.atom_name, "dynamic")) { if (is_dynamic) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } return cut_none(); } } if (prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 1 && !strcmp(prop->v.str.functor, "template")) { if (!is_builtin) { return cut_none(); } if (!strcmp(pred_name, "write") && (pred_arity == 1 || pred_arity == 2)) { pl_term *templ = make_struct_rt(rt_ctrl, dbg_dat_ptr, "write", pred_arity); if (pred_arity == 1) { pl_term *m = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m; } else { pl_term *m1 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m1->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "stream"); pl_term *m2 = make_struct_rt(rt_ctrl, dbg_dat_ptr, "+", 1); m2->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "term"); templ->v.str.args[0] = m1; templ->v.str.args[1] = m2; } pl_term *pt = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 1); pt->v.str.args[0] = templ; const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], pt, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } return cut_none(); } return cut_none(); } if (!strcmp(fn, "evaluable_property") && (ar == 2) && goal->v.str.args) { pl_term *callable = deref_term_wam(goal->v.str.args[0]); if (!callable) { return cut_none(); } if (callable->tag == PL_TERM_VAR) { return throw_instantiation_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_env empty = {0}; if (callable->tag != PL_TERM_ATOM && callable->tag != PL_TERM_STRUCT) { return throw_type_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "callable", callable, &empty, "evaluable_property", 2); } pl_term *prop = deref_term_wam(goal->v.str.args[1]); if (!prop) { return cut_none(); } if (prop->tag != PL_TERM_VAR) { const bool ok_atom = prop->tag == PL_TERM_ATOM && (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static") || !strcmp(prop->v.atom_name, "dynamic")); const bool ok_template = prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 2 && !strcmp(prop->v.str.functor, "template"); if (!ok_atom && !ok_template) { return throw_domain_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "evaluable_property", prop, &empty, "$legacy_evaluable_property", 2); } } const CHR *fn_name = NULL; ULO fn_arity = 0; if (callable->tag == PL_TERM_ATOM) { fn_name = callable->v.atom_name; fn_arity = 0; } else { fn_name = callable->v.str.functor; fn_arity = callable->v.str.arity; } pl_term *templ_prop = NULL; if (fn_name && fn_arity == 0 && (!strcmp(fn_name, "e") || !strcmp(fn_name, "epsilon") || !strcmp(fn_name, "pi"))) { templ_prop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, fn_name); templ_prop->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, "float"); } else if (fn_name && fn_arity == 1) { const CHR *arg_ty = NULL; const CHR *ret_ty = NULL; if (!strcmp(fn_name, "+") || !strcmp(fn_name, "-") || !strcmp(fn_name, "abs") || !strcmp(fn_name, "sign")) { arg_ty = "number"; ret_ty = "number"; } else if (!strcmp(fn_name, "float")) { arg_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "floor") || !strcmp(fn_name, "ceiling") || !strcmp(fn_name, "truncate") || !strcmp(fn_name, "round")) { arg_ty = "float"; ret_ty = "integer"; } else if (!strcmp(fn_name, "float_integer_part") || !strcmp(fn_name, "float_fractional_part")) { arg_ty = "float"; ret_ty = "float"; } else if (!strcmp(fn_name, "sin") || !strcmp(fn_name, "cos") || !strcmp(fn_name, "tan") || !strcmp(fn_name, "asin") || !strcmp(fn_name, "acos") || !strcmp(fn_name, "atan") || !strcmp(fn_name, "sqrt") || !strcmp(fn_name, "log") || !strcmp(fn_name, "exp")) { arg_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "\\")) { arg_ty = "integer"; ret_ty = "integer"; } if (arg_ty && ret_ty) { pl_term *t = make_struct_rt(rt_ctrl, dbg_dat_ptr, fn_name, 1); t->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, arg_ty); templ_prop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = t; templ_prop->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, ret_ty); } } else if (fn_name && fn_arity == 2) { const CHR *a_ty = NULL; const CHR *b_ty = NULL; const CHR *ret_ty = NULL; if (!strcmp(fn_name, "+") || !strcmp(fn_name, "-") || !strcmp(fn_name, "*") || !strcmp(fn_name, "max") || !strcmp(fn_name, "min")) { a_ty = "number"; b_ty = "number"; ret_ty = "number"; } else if (!strcmp(fn_name, "/")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "//") || !strcmp(fn_name, "div") || !strcmp(fn_name, "mod") || !strcmp(fn_name, "rem") || !strcmp(fn_name, "/\\") || !strcmp(fn_name, "\\/") || !strcmp(fn_name, "xor") || !strcmp(fn_name, "<<") || !strcmp(fn_name, ">>")) { a_ty = "integer"; b_ty = "integer"; ret_ty = "integer"; } else if (!strcmp(fn_name, "**")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "^")) { a_ty = "number"; b_ty = "number"; ret_ty = "integer"; } else if (!strcmp(fn_name, "atan2")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } if (a_ty && b_ty && ret_ty) { pl_term *t = make_struct_rt(rt_ctrl, dbg_dat_ptr, fn_name, 2); t->v.str.args[0] = make_atom_rt(rt_ctrl, dbg_dat_ptr, a_ty); t->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, b_ty); templ_prop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = t; templ_prop->v.str.args[1] = make_atom_rt(rt_ctrl, dbg_dat_ptr, ret_ty); } } if (!templ_prop) { return cut_none(); } if (prop->tag == PL_TERM_VAR) { const pl_term *props[] = { make_atom_rt(rt_ctrl, dbg_dat_ptr, "built_in"), make_atom_rt(rt_ctrl, dbg_dat_ptr, "static"), make_atom_rt(rt_ctrl, dbg_dat_ptr, "iso"), templ_prop, }; for (ULO i = 0; i < (sizeof(props) / sizeof(props[0])); i++) { if (stop_at_first && *sol_count) { break; } const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], (pl_term *)props[i], &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); if (r.cut || r.except) { return r; } } return cut_none(); } if (prop->tag == PL_TERM_ATOM) { if (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static")) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(prop->v.atom_name, "dynamic")) { return cut_none(); } } if (prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 2 && !strcmp(prop->v.str.functor, "template")) { const ULO mark = st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], templ_prop, &st->trail, dbg_dat_ptr)) { r = solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } wam_trail_unwind(&st->trail, mark); return r; } return cut_none(); } } // Some atom goals (arity 0) are not assigned builtin ids; handle them here. if (goal->tag == PL_TERM_ATOM && goal->v.atom_name) { if (!strcmp(goal->v.atom_name, "trace")) { if (prog) { prog->flag_trace = true; prog->flag_debug = true; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(goal->v.atom_name, "notrace")) { if (prog) { prog->flag_trace = false; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(goal->v.atom_name, "itrace")) { if (prog) { prog->flag_itrace = true; prog->flag_debug = true; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(goal->v.atom_name, "noitrace")) { if (prog) { prog->flag_itrace = false; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(goal->v.atom_name, "debug")) { if (prog) { prog->flag_debug = true; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(goal->v.atom_name, "nodebug")) { if (prog) { prog->flag_debug = false; } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(goal->v.atom_name, "listing")) { streams_init(dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, dbg_dat_ptr)) { return cut_none(); } pl_env empty = {0}; if (!s->writable) { pl_term *cur = make_stream_term_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "stream", cur, &empty, "listing", 0); } if (s->binary) { pl_term *sid = make_int_rt(rt_ctrl, dbg_dat_ptr, id); return throw_permission_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "output", "binary_stream", sid, &empty, "listing", 0); } const pl_clause **snap = NULL; ULO snap_count = 0; if (prog && prog->clauses && prog->clause_count) { prog_db_rlock(prog); snap = (const pl_clause **)pool_alloc(rt_ctrl, sizeof(*snap) * prog->clause_count, dbg_dat_ptr); for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses[i]; if (!cl || !cl->head) { continue; } snap[snap_count++] = cl; } prog_db_runlock(prog); } for (ULO i = 0; i < snap_count; i++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = snap[i]; if (!cl || !cl->head) { continue; } pl_temp_mark m = {0}; const bool release_temp = (g_temp_alloc != NULL); if (release_temp) { m = temp_alloc_mark(g_temp_alloc); } pl_term *t = cl->head; if (cl->body_count && cl->body) { pl_term **body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = cl->body[bi + 1]; } pl_term *body_term = build_conjunction_rt(rt_ctrl, dbg_dat_ptr, body_goals, cl->body_count); pl_term *rule = make_struct_rt(rt_ctrl, dbg_dat_ptr, ":-", 2); rule->v.str.args[0] = cl->head; rule->v.str.args[1] = body_term; t = rule; } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false}; write_term_to_sbuf(prog ? prog->op_overrides : NULL, t, cl->env, &wopts, &sb, dbg_dat_ptr); sbuf_append_char(&sb, '.'); sbuf_append_char(&sb, '\n'); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); if (release_temp) { temp_alloc_release(g_temp_alloc, m, rt_ctrl, dbg_dat_ptr); } } if (id != 1) { (void)fflush(s->fp); } return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } if (!strcmp(goal->v.atom_name, "at_end_of_stream")) { streams_init(dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(g_streams.current_input, &s, dbg_dat_ptr) || !s->readable) { return cut_none(); } if (s->pushback_count) { return cut_none(); } const int c = fgetc(s->fp); if (c == EOF) { return solve_goals_wam_cb(prog, q, goals + 1, goal_count - 1, st, cut_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } stream_pushback_push(s, dbg_dat_ptr, (SLO)(unsigned char)c); return cut_none(); } } // User predicate call. const CHR *goal_name = NULL; ULO goal_arity = 0; if (goal->tag == PL_TERM_ATOM) { goal_name = goal->v.atom_name; goal_arity = 0; } else if (goal->tag == PL_TERM_STRUCT) { goal_name = goal->v.str.functor; goal_arity = goal->v.str.arity; } if (!prog || !goal_name) { return cut_none(); } // Flowlog extension: call-by-variant tabling for predicates declared via `:- table/1`. if (g_table_state && !builtin_pred_defined(goal_name, goal_arity) && prog_tabled_pred_contains(prog, goal_name, goal_arity)) { return table_call_wam(prog, q, goal, goals, goal_count, st, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, cont); } const unsigned long idx_cur = atomic_load_explicit(&prog->clause_epoch, memory_order_acquire); const unsigned long idx_built = atomic_load_explicit(&prog->index_epoch, memory_order_acquire); if (idx_built != idx_cur) { prog_index_ensure(prog, rt_ctrl, dbg_dat_ptr); } const pl_clause **cands = NULL; ULO cand_count = 0; if (prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(prog->pred_index, goal_name, goal_arity); if (e && e->clauses && e->clause_count) { cands = e->clauses; cand_count = e->clause_count; } } if (!cands || !cand_count) { if (prog && prog->flag_unknown == PL_UNKNOWN_ERROR) { pl_env empty = {0}; pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, goal_name, goal_arity); return throw_existence_error(exc_barrier, rt_ctrl, dbg_dat_ptr, "procedure", pi, &empty, goal_name, goal_arity); } if (prog && prog->flag_trace) { trace_emit_prolog_goal('!', depth, "FAIL", goal, NULL); } return cut_none(); } int pred_barrier = 0; const bool orpar_alt_ok = (cand_count >= FLOWLOG_ORPAR_MIN_ALT_THRESHOLD); const bool orpar_depth_ok = ((SLO)depth < prog->flag_parallel_max_depth) || (cand_count >= FLOWLOG_ORPAR_BIG_ALT_THRESHOLD); const bool par_or = prog && g_par_state && (g_table_state == NULL) && ((SLO)g_orpar_level <= prog->flag_parallel_or_nesting) && prog->flag_parallel_or && (prog->flag_parallel_max_depth > 0) && orpar_alt_ok && orpar_depth_ok && !stop_at_first && (cand_count > 1); if (par_or) { const uint64_t orpar_t0 = flowlog_monotonic_ns(); const ULO alt_count = cand_count; ULO worker_count = orpar_worker_count_for_alts(alt_count, (ULO)g_par_state->max_threads); int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } if (worker_count < 2) { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } else { const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const SLO outer_barrier_value = (SLO)(uintptr_t)cut_barrier; pl_term *outer_barrier_term = make_int_rt(rt_ctrl, dbg_dat_ptr, outer_barrier_value); pl_term *drop = make_struct_rt(rt_ctrl, dbg_dat_ptr, "$drop_barrier", 1); drop->v.str.args[0] = outer_barrier_term; const pl_wam_cont *cont_copy = wam_cont_clone(cont, rt_ctrl, dbg_dat_ptr); ULO chunk_count = worker_count * 128; const ULO chunk_cap = 16384; if (chunk_count > chunk_cap) { chunk_count = chunk_cap; } if (chunk_count > alt_count) { chunk_count = alt_count; } if (!chunk_count) { chunk_count = alt_count; } flowlog_debug_orpar_log_start(goal_name, goal_arity, alt_count, worker_count, chunk_count, depth, stop_at_first); pl_or_job *workers = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*workers) * worker_count, dbg_dat_ptr); memset(workers, 0, sizeof(*workers) * worker_count); pl_or_job *chunks = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*chunks) * chunk_count, dbg_dat_ptr); memset(chunks, 0, sizeof(*chunks) * chunk_count); pl_or_work *work = (pl_or_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->count = worker_count; work->jobs = workers; work->chunk_count = chunk_count; work->chunks = chunks; work->unordered = (prog->flag_parallel_or_order == PL_OR_UNORDERED); atomic_init(&work->next_chunk, 0); atomic_init(&work->commit_chunk, 0); atomic_init(&work->max_chunk, (unsigned long)(chunk_count ? (chunk_count - 1) : 0)); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; atomic_init(&work->budget_returned, 0); work->budget_total = remote_taken; work->dbg_t0_ns = orpar_t0; atomic_init(&work->dbg_first_cut_chunk, (unsigned long)ULONG_MAX); for (ULO i = 0; i < chunk_count; i++) { const ULO start = (ULO)(((unsigned __int128)i * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); ULO end = (ULO)(((unsigned __int128)(i + 1) * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); if (end > alt_count) { end = alt_count; } chunks[i] = (pl_or_job){ .kind = ((end - start) == 1) ? PL_OR_JOB_WAM_CLAUSE : PL_OR_JOB_WAM_CLAUSE_RANGE, .prog = prog, .q = q, .goal = goal, .env_in = NULL, .wam_in = st, .wam_cont = cont_copy, .drop = drop, .rest_goals = (pl_term *const *)(goals + 1), .rest_count = goal_count ? (goal_count - 1) : 0, .cut_barrier = &pred_barrier, .exc_barrier = exc_barrier, .depth = depth, .stop_at_first = stop_at_first, .capture_solution_output = (out != NULL) || (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .capture_solution_spans = (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .on_solution = NULL, .on_solution_ctx = NULL, .wam_on_solution = g_wam_on_solution, .wam_on_solution_ctx = g_wam_on_solution_ctx, .on_solution_safe_temp_release = g_on_solution_safe_temp_release, // Use process-local allocation for query-temporary objects to // reduce shared-memory allocator contention in OR-par workers. .local_alloc_ok = true, .stringify_exceptions = false, .chunk_index = i, .work_done = NULL, .work_cancel = &work->cancel, }; atomic_init(&chunks[i].done, 0); if ((end - start) == 1) { chunks[i].u.cl = cands[start]; } else { chunks[i].u.clause_range.cands = cands; chunks[i].u.clause_range.start = start; chunks[i].u.clause_range.end = end; } } for (ULO i = 0; i < worker_count; i++) { workers[i] = (pl_or_job){ .kind = PL_OR_JOB_WORKER, .prog = prog, .work_done = &work->done, .work_cancel = &work->cancel, }; workers[i].u.worker.work = work; workers[i].budget_return = (i == 0) ? 0 : 1; atomic_init(&workers[i].done, 0); } pl_cut_signal ret = cut_none(); bool stopped = false; const ULO started = flowlog_start_or_work(work, 2, rt_ctrl, dbg_dat_ptr); if (g_par_budget && remote_taken && ((int)started < remote_taken)) { par_global_budget_give(g_par_budget, remote_taken - (int)started); remote_taken = (int)started; work->budget_total = remote_taken; } if (!work->unordered) { ULO last_done = 0; for (ULO i = 0; i < chunk_count; i++) { atomic_store(&work->commit_chunk, (unsigned long)i); pl_or_job *j = &chunks[i]; while (!atomic_load(&j->done)) { if (flowlog_cancelled()) { break; } // Help progress the work while waiting for ordered chunk i to complete. unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { if (j->sig.target == &pred_barrier) { ret = cut_none(); } else { ret = j->sig; } stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); last_done = i + 1; if (stopped) { break; } } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); if (stopped && (last_done < chunk_count)) { for (ULO i = last_done; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } } else { ULO done_count = 0; ULO scan = 0; pl_or_job *stop_job = NULL; while (done_count < chunk_count) { if (flowlog_cancelled()) { break; } bool progressed = false; for (ULO n = 0; n < chunk_count; n++) { const ULO idx = (scan + n) % chunk_count; pl_or_job *j = &chunks[idx]; const int done = atomic_load(&j->done); if (done != 1) { continue; } done_count++; scan = idx + 1; progressed = true; pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } if (j->sig.cut) { if (j->sig.target == &pred_barrier) { ret = cut_none(); } else { ret = j->sig; } stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); atomic_store(&j->done, 2); } if (stopped) { break; } if (progressed) { continue; } if (atomic_load_explicit(&work->cancel, memory_order_relaxed)) { usleep(1000); continue; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); for (ULO i = 0; i < chunk_count; i++) { pl_or_job *j = &chunks[i]; if (j == stop_job) { continue; } if (atomic_load(&j->done) == 2) { continue; } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); } if (stop_job) { pl_or_job_dispose(stop_job, rt_ctrl, dbg_dat_ptr); } } flowlog_debug_orpar_log_stop(goal_name, goal_arity, alt_count, flowlog_monotonic_ns() - orpar_t0, stopped, atomic_load(&work->cancel) != 0); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (!ret.cut && !ret.except && prog && prog->flag_trace) { trace_emit_prolog_goal('!', depth, "FAIL", goal, NULL); } return ret; } } const bool use_wamvm = (g_engine_active == PL_ENGINE_WAMVM); for (ULO ci = 0; ci < cand_count; ci++) { const pl_clause *cl = cands[ci]; if (!cl || !cl->head) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = st->trail.count; pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(st, scope, cl->var_count, rt_ctrl, dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *vars = NULL; if (use_wamvm && cl->var_count) { vars = (pl_term *)pool_alloc(rt_ctrl, sizeof(*vars) * cl->var_count, dbg_dat_ptr); wamvm_vars_init(vars, cl->var_count, scope); } if (use_wamvm) { wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st->trail, rt_ctrl, dbg_dat_ptr); if (!wamvm_unify_against_clause_term(raw_goal, cl->head, cl->scope, vars, cl->var_count, &st->trail, &arena, dbg_dat_ptr, 0)) { wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } } else { pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &st->trail, rt_ctrl, dbg_dat_ptr); if (!unify_terms_wam(raw_goal, head, &st->trail, dbg_dat_ptr)) { wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } } pl_wam_cont next = { .goals = goals + 1, .goal_count = goal_count - 1, .cut_barrier = cut_barrier, .trace_pred_depth_plus1 = (uint16_t)(depth + 1u), .trace_clause = cl, .trace_call_goal = goal, .next = cont, }; const pl_clause *saved_clause = g_trace_clause; const pl_clause *saved_argv_clause = flowlog_argv_clause_push(cl); g_trace_clause = cl; pl_cut_signal r = cut_none(); if (!cl->body_count) { r = solve_goals_wam_cb(prog, q, NULL, 0, st, &pred_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, &next); } else { pl_term **body_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * cl->body_count, dbg_dat_ptr); for (ULO j = 1; j <= cl->body_count; j++) { if (use_wamvm) { body_goals[j - 1] = wamvm_instantiate_term_arena(cl->body[j], cl->scope, vars, cl->var_count, &arena, dbg_dat_ptr, 0); } else { body_goals[j - 1] = clone_term_with_scope_arena(cl->body[j], cl->scope, scope, &arena, dbg_dat_ptr, 0); } } r = solve_goals_wam_cb(prog, q, body_goals, cl->body_count, st, &pred_barrier, exc_barrier, depth + 1, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, &next); } flowlog_argv_clause_pop(saved_argv_clause); g_trace_clause = saved_clause; wam_trail_unwind(&st->trail, mark); wam_state_pop_scope(st, scope); if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } if (r.except) { return r; } if (r.cut) { if (r.target == &pred_barrier) { return cut_none(); } return r; } } if (prog && prog->flag_trace) { trace_emit_prolog_goal('!', depth, "FAIL", goal, NULL); } return cut_none(); } static pl_cut_signal solve_goals_wam(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_wam_state *saved = g_wam_state; g_wam_state = st; pl_cut_signal r = solve_goals_wam_cb( prog, q, goals, goal_count, st, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, NULL); g_wam_state = saved; return r; } /* ============================================================================ * SECTION 24: WAMVM VM * bytecode execution engine and choicepoint handling. * ============================================================================ */ /* --- SUBSECTION 24.1: VM Frames & State ---------------------------------- */ // WAMVM frames and choicepoint snapshotting. // wamvm_vm_vec_reserve_frames_snap(), wamvm_vm_cp_snapshot_capture()/restore()/release() manage VM stacks for OR-par and cuts. typedef enum { PL_WAMVM_FRAME_GOALS = 1, // array of goals (0-based) PL_WAMVM_FRAME_GOAL1 = 2, // single goal term PL_WAMVM_FRAME_CLAUSE = 3, // compiled clause body (bytecode) } pl_wamvm_frame_kind; typedef struct { const pl_wamvm_clause_code *code; const pl_clause *cl; pl_term *call_goal; pl_scope *scope; pl_term_arena arena; pl_term *vars; ULO var_count; pl_term **inst; // cached instantiated goals per instruction slot (NULL for PROCEED slots) ULO inst_cap; } pl_wamvm_clause_frame; typedef struct { pl_wamvm_frame_kind kind; ULO depth; const pl_wamvm_barrier *cut_barrier; const void *exc_barrier; ULO pc; // goal index (GOALS), 0/1 (GOAL1), instruction index (CLAUSE) union { struct { pl_term *const *goals; ULO goal_count; } goals; struct { pl_term *goal; } goal1; struct { pl_wamvm_clause_frame *cf; } clause; } u; } pl_wamvm_frame; typedef enum { PL_WAMVM_CP_DISJ = 1, // ;/2 second branch PL_WAMVM_CP_PRED_CLAUSE = 2, // user predicate next clause PL_WAMVM_CP_REPEAT = 3, // repeat/0 choicepoint PL_WAMVM_CP_CATCH = 4, // catch/3 exception handler PL_WAMVM_CP_RETRACT = 5, // retract/1 next matching clause PL_WAMVM_CP_SELECT1 = 6 // select1/3 (and select_/3) generator } pl_wamvm_cp_kind; typedef struct { pl_wamvm_cp_kind kind; // Restore the VM to this frame stack depth and resume after the original goal. ULO frame_count; ULO frame_pc; const pl_wamvm_barrier *frame_cut_barrier; const void *frame_exc_barrier; ULO frame_depth; // Snapshot of the VM frame stack at choicepoint creation. // // The WAMVM uses a separate explicit frame stack. Unlike a classic WAM // environment stack (where choicepoints protect older stack frames from being // overwritten), WAMVM frames can be popped and later reused while older // choicepoints are still alive. // // To ensure correct semantics for nested control constructs (notably `,/2` // combined with `;/2` inside meta-predicates like findall/3), we store a copy // of the frame stack so backtracking can restore sibling frame state (pc, // goal pointers, etc.) reliably. // // Snapshots are allocated from a LIFO arena owned by the VM (so we avoid a // malloc/free pair per choicepoint). `frames_snapshot_idx` is a 0-based index // into `vm->frames_snap`. ULO frames_snapshot_idx; ULO frames_snapshot_count; // Restore WAM bindings/scopes and query-temporary allocations. ULO trail_mark; ULO scope_mark; pl_temp_mark tmp_mark; union { struct { pl_term *g2; } disj; struct { pl_term *call_goal; const pl_wamvm_pred_code *pred; ULO next_ci; const pl_wamvm_barrier *call_barrier; unsigned char had_exit; } pred; struct { const void *local_exc; const void *outer_exc; const pl_wamvm_barrier *cut_barrier; pl_term *catcher; pl_term *recover; } catch; struct { const CHR *target_name; ULO target_arity; pl_term *pattern; ULO next_i; ULO snap_count; } retract; struct { pl_term *goal; pl_term *list0; const CHR *cons_functor; ULO next_idx; ULO end_idx; // exclusive; ~(ULO)0 means "no upper bound" ULO cycle_start; ULO cycle_len; unsigned char more; } select1; } u; } pl_wamvm_choicepoint; typedef struct { pl_program *prog; const pl_query *q; pl_wam_state *st; bool stop_at_first; pl_sbuf *out; ULO *sol_count; const void *rt_ctrl; const ULO *dbg_dat_ptr; bool release_temp; const pl_wamvm_barrier *base_cut_barrier; bool cut_at_base; pl_wamvm_frame *frames; ULO frame_count; ULO frame_cap; pl_wamvm_choicepoint *cps; ULO cp_count; ULO cp_cap; // LIFO arena for frame snapshots (used by choicepoints). pl_wamvm_frame *frames_snap; ULO frames_snap_top; ULO frames_snap_cap; } pl_wamvm_vm; // Thread-local reuse of VM scratch buffers (frames/cps/snapshots) to avoid // repeated malloc/free overhead in OR-par worker threads. Disabled for nested // VM invocations (e.g. meta-predicates probing sub-goals) to keep reentrancy // simple and correct. typedef struct { pl_wamvm_frame *frames; ULO frame_cap; pl_wamvm_choicepoint *cps; ULO cp_cap; pl_wamvm_frame *frames_snap; ULO frames_snap_cap; } pl_wamvm_vm_scratch; static FLOWLOG_TLS pl_wamvm_vm_scratch g_wamvm_vm_scratch = {0}; static FLOWLOG_TLS unsigned g_wamvm_vm_scratch_depth = 0; // Forward declarations for helpers used by snapshot restore. static void wamvm_vm_vec_reserve_frames(pl_wamvm_vm *vm, ULO need); static void wamvm_vm_vec_reserve_frames_snap(pl_wamvm_vm *vm, ULO need) { if (!vm) { return; } if (need <= vm->frames_snap_cap) { return; } ULO new_cap = vm->frames_snap_cap ? vm->frames_snap_cap : 64; while (new_cap < need) { new_cap *= 2; } pl_wamvm_frame *nf = (pl_wamvm_frame *)realloc(vm->frames_snap, sizeof(*nf) * new_cap); if (!nf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } vm->frames_snap = nf; vm->frames_snap_cap = new_cap; } static void wamvm_vm_cp_snapshot_capture(pl_wamvm_vm *vm, pl_wamvm_choicepoint *cp) { if (!vm || !cp) { return; } const ULO n = cp->frame_count; cp->frames_snapshot_idx = vm->frames_snap_top; cp->frames_snapshot_count = n; if (g_wamvm_prof_nesting > 0) { g_wamvm_prof_snap_captures++; g_wamvm_prof_snap_capture_frames += (uint64_t)n; } if (!n) { return; } wamvm_vm_vec_reserve_frames_snap(vm, vm->frames_snap_top + n); memcpy(vm->frames_snap + cp->frames_snapshot_idx, vm->frames, sizeof(*vm->frames) * n); vm->frames_snap_top += n; } static bool wamvm_vm_cp_snapshot_restore(pl_wamvm_vm *vm, const pl_wamvm_choicepoint *cp) { if (!vm || !cp) { return false; } if (!cp->frame_count) { return true; } if (!vm->frames_snap || (cp->frames_snapshot_count != cp->frame_count)) { return false; } if ((cp->frames_snapshot_idx + cp->frames_snapshot_count) > vm->frames_snap_top) { return false; } if (g_wamvm_prof_nesting > 0) { g_wamvm_prof_snap_restores++; g_wamvm_prof_snap_restore_frames += (uint64_t)cp->frame_count; } wamvm_vm_vec_reserve_frames(vm, cp->frame_count); memcpy(vm->frames, vm->frames_snap + cp->frames_snapshot_idx, sizeof(*vm->frames) * cp->frame_count); return true; } static void wamvm_vm_cp_snapshot_release(pl_wamvm_vm *vm, const pl_wamvm_choicepoint *cp) { if (!vm || !cp) { return; } if (cp->frames_snapshot_idx > vm->frames_snap_top) { return; } // Choicepoints are popped LIFO; rewinding releases this snapshot and any // newer allocations (there should be none when called correctly). vm->frames_snap_top = cp->frames_snapshot_idx; } static void wamvm_vm_cps_drop_to(pl_wamvm_vm *vm, ULO new_count) { if (!vm) { return; } if (new_count >= vm->cp_count) { vm->cp_count = new_count; return; } // LIFO snapshot arena: rewind to the end of the last kept choicepoint. ULO new_snap_top = 0; if (new_count) { pl_wamvm_choicepoint *last = &vm->cps[new_count - 1]; new_snap_top = last->frames_snapshot_idx + last->frames_snapshot_count; } if (new_snap_top <= vm->frames_snap_top) { vm->frames_snap_top = new_snap_top; } vm->cp_count = new_count; } static void wamvm_vm_free(pl_wamvm_vm *vm) { if (!vm) { return; } free(vm->frames); free(vm->cps); free(vm->frames_snap); vm->frames = NULL; vm->cps = NULL; vm->frames_snap = NULL; vm->frame_count = 0; vm->frame_cap = 0; vm->cp_count = 0; vm->cp_cap = 0; vm->frames_snap_top = 0; vm->frames_snap_cap = 0; } static void wamvm_vm_vec_reserve_frames(pl_wamvm_vm *vm, ULO need) { if (!vm) { return; } if (need <= vm->frame_cap) { return; } ULO new_cap = vm->frame_cap ? vm->frame_cap : 32; while (new_cap < need) { new_cap *= 2; } pl_wamvm_frame *nf = (pl_wamvm_frame *)realloc(vm->frames, sizeof(*nf) * new_cap); if (!nf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } vm->frames = nf; vm->frame_cap = new_cap; } static void wamvm_vm_vec_reserve_cps(pl_wamvm_vm *vm, ULO need) { if (!vm) { return; } if (need <= vm->cp_cap) { return; } ULO new_cap = vm->cp_cap ? vm->cp_cap : 32; while (new_cap < need) { new_cap *= 2; } pl_wamvm_choicepoint *nc = (pl_wamvm_choicepoint *)realloc(vm->cps, sizeof(*nc) * new_cap); if (!nc) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } vm->cps = nc; vm->cp_cap = new_cap; } static void wamvm_vm_push_frame_goals(pl_wamvm_vm *vm, pl_term *const *goals, ULO goal_count, const pl_wamvm_barrier *cut_barrier, const void *exc_barrier, ULO depth) { if (!vm) { return; } wamvm_vm_vec_reserve_frames(vm, vm->frame_count + 1); pl_wamvm_frame *f = &vm->frames[vm->frame_count++]; f->kind = PL_WAMVM_FRAME_GOALS; f->depth = depth; f->cut_barrier = cut_barrier; f->exc_barrier = exc_barrier; f->pc = 0; f->u.goals.goals = goals; f->u.goals.goal_count = goal_count; } static void wamvm_vm_push_frame_goal1(pl_wamvm_vm *vm, pl_term *goal, const pl_wamvm_barrier *cut_barrier, const void *exc_barrier, ULO depth) { if (!vm) { return; } wamvm_vm_vec_reserve_frames(vm, vm->frame_count + 1); pl_wamvm_frame *f = &vm->frames[vm->frame_count++]; f->kind = PL_WAMVM_FRAME_GOAL1; f->depth = depth; f->cut_barrier = cut_barrier; f->exc_barrier = exc_barrier; f->pc = 0; f->u.goal1.goal = goal; } static bool wamvm_vm_frame_slice_goals(pl_wamvm_vm *vm, pl_wamvm_frame *f, ULO pc_start, pl_term *const **out_goals, ULO *out_goal_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { (void)rt_ctrl; if (out_goals) { *out_goals = NULL; } if (out_goal_count) { *out_goal_count = 0; } if (!vm || !f || !out_goals || !out_goal_count) { return false; } if (f->kind == PL_WAMVM_FRAME_GOALS) { if (!f->u.goals.goals || !f->u.goals.goal_count || pc_start >= f->u.goals.goal_count) { return true; } *out_goals = (pl_term *const *)(f->u.goals.goals + pc_start); *out_goal_count = f->u.goals.goal_count - pc_start; return true; } if (f->kind == PL_WAMVM_FRAME_GOAL1) { if (pc_start >= 1 || !f->u.goal1.goal) { return true; } // Expose the goal pointer directly as a 1-element goal slice (stable while the VM is paused for OR-par work). *out_goals = (pl_term *const *)&f->u.goal1.goal; *out_goal_count = 1; return true; } if (f->kind == PL_WAMVM_FRAME_CLAUSE) { pl_wamvm_clause_frame *cf = f->u.clause.cf; const pl_wamvm_clause_code *cc = cf ? cf->code : NULL; if (!cc || !cc->insn || !cc->insn_count || pc_start >= cc->insn_count) { return true; } // Current WAMVM bytecode uses a simple CALL* + PROCEED instruction stream. // Build a compact slice of instantiated goals so the continuation is a // dense pointer array (helps cache locality in OR-par workers). const ULO call_end = cc->insn_count ? (cc->insn_count - 1) : 0; // exclude PROCEED slot if (pc_start >= call_end) { return true; } if (!cf || !cf->inst) { return false; } const ULO count = call_end - pc_start; pl_term **arr = (pl_term **)pool_alloc(rt_ctrl, sizeof(*arr) * count, dbg_dat_ptr); for (ULO i = pc_start; i < call_end; i++) { pl_term *inst_goal = cf->inst[i]; if (!inst_goal) { inst_goal = wamvm_instantiate_term_arena( cc->insn[i].goal, cf->cl ? cf->cl->scope : NULL, cf->vars, cf->var_count, &cf->arena, dbg_dat_ptr, 0); cf->inst[i] = inst_goal; } arr[i - pc_start] = inst_goal; } *out_goals = (pl_term *const *)arr; *out_goal_count = count; return true; } return false; } static bool wamvm_vm_build_cont_after_goal(pl_wamvm_vm *vm, pl_wamvm_frame *frame, ULO pc_after, pl_term *const **out_goals, ULO *out_goal_count, const pl_wam_cont **out_cont, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (out_goals) { *out_goals = NULL; } if (out_goal_count) { *out_goal_count = 0; } if (out_cont) { *out_cont = NULL; } if (!vm || !frame || !out_goals || !out_goal_count || !out_cont) { return false; } const ULO frame_idx = (ULO)(frame - vm->frames); if (frame_idx >= vm->frame_count) { return false; } // Base segment: remainder of the current frame after the current goal. if (!wamvm_vm_frame_slice_goals(vm, frame, pc_after, out_goals, out_goal_count, rt_ctrl, dbg_dat_ptr)) { return false; } // Continuation: remaining work in frames below the current top frame. pl_wam_cont *cont_nodes = NULL; if (frame_idx) { cont_nodes = (pl_wam_cont *)pool_alloc(rt_ctrl, sizeof(*cont_nodes) * frame_idx, dbg_dat_ptr); } ULO cont_used = 0; const pl_wam_cont *cont_head = NULL; for (ULO i = 0; i < frame_idx; i++) { pl_wamvm_frame *f = &vm->frames[i]; pl_term *const *seg_goals = NULL; ULO seg_count = 0; if (!wamvm_vm_frame_slice_goals(vm, f, f->pc, &seg_goals, &seg_count, rt_ctrl, dbg_dat_ptr)) { return false; } if (!seg_count) { continue; } pl_wam_cont *node = cont_nodes ? &cont_nodes[cont_used++] : (pl_wam_cont *)pool_alloc(rt_ctrl, sizeof(*node), dbg_dat_ptr); *node = (pl_wam_cont){ .goals = seg_goals, .goal_count = seg_count, .cut_barrier = (const void *)f->cut_barrier, .trace_pred_depth_plus1 = 0, .trace_clause = NULL, .trace_call_goal = NULL, .next = cont_head, }; cont_head = node; } *out_cont = cont_head; return true; } static const pl_wamvm_pred_code *wamvm_code_find_pred(const pl_wamvm_prog_code *pc, const CHR *name, ULO arity) { if (!pc || !pc->prog || !pc->prog->pred_index || !pc->preds || !name) { return NULL; } pl_pred_index *idx = pc->prog->pred_index; pl_pred_index_entry *e = pred_index_find_pred(idx, name, arity); if (!e || !idx->preds) { return NULL; } const ULO pi = (ULO)(e - idx->preds); if (pi >= pc->pred_count) { return NULL; } return &pc->preds[pi]; } static bool wamvm_vm_builtin_supported(const CHR *name, ULO arity) { if (!name) { return false; } if (!strcmp(name, "call") && (arity >= 1 && arity <= 8)) { return true; } if (arity == 0) { return !strcmp(name, "true") || !strcmp(name, "fail") || !strcmp(name, "false") || !strcmp(name, "repeat") || !strcmp(name, "nl") || !strcmp(name, "flush_output") || !strcmp(name, "at_end_of_stream") || !strcmp(name, "listing") || !strcmp(name, "!") || !strcmp(name, "halt"); } if (arity == 1) { return !strcmp(name, "\\+") || !strcmp(name, "$drop_barrier") || !strcmp(name, "$drop_exc_barrier") || !strcmp(name, "var") || !strcmp(name, "nonvar") || !strcmp(name, "atom") || !strcmp(name, "integer") || !strcmp(name, "float") || !strcmp(name, "number") || !strcmp(name, "atomic") || !strcmp(name, "compound") || !strcmp(name, "callable") || !strcmp(name, "once") || !strcmp(name, "ground") || !strcmp(name, "acyclic_term") || !strcmp(name, "throw") || !strcmp(name, "current_input") || !strcmp(name, "current_output") || !strcmp(name, "current_error") || !strcmp(name, "set_input") || !strcmp(name, "set_output") || !strcmp(name, "set_error") || !strcmp(name, "nl") || !strcmp(name, "flush_output") || !strcmp(name, "at_end_of_stream") || !strcmp(name, "tab") || !strcmp(name, "get_code") || !strcmp(name, "peek_code") || !strcmp(name, "put_code") || !strcmp(name, "unget_code") || !strcmp(name, "get_char") || !strcmp(name, "peek_char") || !strcmp(name, "put_char") || !strcmp(name, "unget_char") || !strcmp(name, "get_byte") || !strcmp(name, "peek_byte") || !strcmp(name, "put_byte") || !strcmp(name, "unget_byte") || !strcmp(name, "close") || !strcmp(name, "read") || !strcmp(name, "write") || !strcmp(name, "writeq") || !strcmp(name, "write_canonical") || !strcmp(name, "asserta") || !strcmp(name, "assertz") || !strcmp(name, "assert") || !strcmp(name, "retract") || !strcmp(name, "retractall") || !strcmp(name, "abolish") || !strcmp(name, "dynamic") || !strcmp(name, "current_predicate") || !strcmp(name, "current_rule") || !strcmp(name, "listing") || !strcmp(name, "flowlog_cpuproc_id") || !strcmp(name, "flowlog_n_cpuproc") || !strcmp(name, "flowlog_in_cpuproc") || !strcmp(name, "flowlog_taskjob_id") || !strcmp(name, "flowlog_n_taskjob") || !strcmp(name, "flowlog_last_tc_cp_mask") || !strcmp(name, "flowlog_last_tc_cp_count") || !strcmp(name, "flowlog_last_tc_worker_count") || !strcmp(name, "flowlog_last_tc_start_ok") || !strcmp(name, "flowlog_last_tc_start_error_code") || !strcmp(name, "flowlog_last_tc_start_error_text") || !strcmp(name, "$flowlog_sleep_ms") || !strcmp(name, "$flowlog_inference_limit") || !strcmp(name, "$flowlog_inference_limit_shared"); } if (arity == 2) { return !strcmp(name, ",") || !strcmp(name, ";") || !strcmp(name, "=") || !strcmp(name, "\\=") || !strcmp(name, "==") || !strcmp(name, "\\==") || !strcmp(name, "=@=") || !strcmp(name, "\\=@=") || !strcmp(name, "@<") || !strcmp(name, "@=<") || !strcmp(name, "@>") || !strcmp(name, "@>=") || !strcmp(name, "is") || !strcmp(name, "=:=") || !strcmp(name, "=\\=") || !strcmp(name, "<") || !strcmp(name, "=<") || !strcmp(name, ">") || !strcmp(name, ">=") || !strcmp(name, "length") || !strcmp(name, "->") || !strcmp(name, ":") || !strcmp(name, "=..") || !strcmp(name, "unify_with_occurs_check") || !strcmp(name, "subsumes_term") || !strcmp(name, "term_variables") || !strcmp(name, "copy_term") || !strcmp(name, "char_code") || !strcmp(name, "atom_chars") || !strcmp(name, "atom_codes") || !strcmp(name, "atom_length") || !strcmp(name, "number_chars") || !strcmp(name, "number_codes") || !strcmp(name, "char_conversion") || !strcmp(name, "current_char_conversion") || !strcmp(name, "sort") || !strcmp(name, "msort") || !strcmp(name, "keysort") || !strcmp(name, "read") || !strcmp(name, "read_term") || !strcmp(name, "file_to_chars") || !strcmp(name, "file_to_bytes") || !strcmp(name, "file_to_byte") || !strcmp(name, "write") || !strcmp(name, "writeq") || !strcmp(name, "write_canonical") || !strcmp(name, "write_term") || !strcmp(name, "close") || !strcmp(name, "clause") || !strcmp(name, "predicate_property") || !strcmp(name, "evaluable_property") || !strcmp(name, "current_prolog_flag") || !strcmp(name, "set_prolog_flag") || !strcmp(name, "stream_property") || !strcmp(name, "set_stream") || !strcmp(name, "set_stream_position") || !strcmp(name, "get_code") || !strcmp(name, "get_char") || !strcmp(name, "get_byte") || !strcmp(name, "peek_code") || !strcmp(name, "peek_char") || !strcmp(name, "peek_byte") || !strcmp(name, "unget_code") || !strcmp(name, "unget_char") || !strcmp(name, "unget_byte") || !strcmp(name, "put_code") || !strcmp(name, "put_char") || !strcmp(name, "put_byte") || !strcmp(name, "tab") || !strcmp(name, "flowlog_db_epochs") || !strcmp(name, "flowlog_and_safe") || !strcmp(name, "flowlog_and_safe_goal"); } if (arity == 3) { return !strcmp(name, "findall") || !strcmp(name, "bagof") || !strcmp(name, "setof") || !strcmp(name, "catch") || !strcmp(name, "functor") || !strcmp(name, "arg") || !strcmp(name, "compare") || !strcmp(name, "read_term") || !strcmp(name, "write_term") || !strcmp(name, "open") || !strcmp(name, "atom_concat") || !strcmp(name, "current_op") || !strcmp(name, "op") || !strcmp(name, "bounds_possible") || !strcmp(name, "numbervars"); } if (arity == 4) { return !strcmp(name, "open"); } if (arity == 5) { return !strcmp(name, "sub_atom") || !strcmp(name, "sub_string"); } return false; } static bool wamvm_vm_goal_supported_tr(const pl_term *goal, ULO depth) { if (!goal || FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return false; } // Variable goals (and non-callable terms) are "supported" in the sense that the VM // can raise the correct ISO instantiation/type errors at runtime. if (goal->tag == PL_TERM_VAR) { return true; } if (goal->tag != PL_TERM_ATOM && goal->tag != PL_TERM_STRUCT) { return true; } const CHR *name = NULL; ULO arity = 0; const pl_term *a0 = NULL; const pl_term *a1 = NULL; const pl_term *a2 = NULL; if (goal->tag == PL_TERM_ATOM) { name = goal->v.atom_name; arity = 0; } else if (goal->tag == PL_TERM_STRUCT) { name = goal->v.str.functor; arity = goal->v.str.arity; if (goal->v.str.args) { if (arity >= 1) a0 = goal->v.str.args[0]; if (arity >= 2) a1 = goal->v.str.args[1]; if (arity >= 3) a2 = goal->v.str.args[2]; } } if (!name) { return false; } if (builtin_pred_defined(name, arity) && !wamvm_vm_builtin_supported(name, arity)) { return false; } // For the supported meta/control built-ins, ensure goal arguments are supported. if (!strcmp(name, ",")) { return a0 && a1 && wamvm_vm_goal_supported_tr(a0, depth + 1) && wamvm_vm_goal_supported_tr(a1, depth + 1); } if (!strcmp(name, ";")) { return a0 && a1 && wamvm_vm_goal_supported_tr(a0, depth + 1) && wamvm_vm_goal_supported_tr(a1, depth + 1); } if (!strcmp(name, "->") && arity == 2) { return a0 && a1 && wamvm_vm_goal_supported_tr(a0, depth + 1) && wamvm_vm_goal_supported_tr(a1, depth + 1); } if (!strcmp(name, "\\+") && arity == 1) { return a0 && wamvm_vm_goal_supported_tr(a0, depth + 1); } if (!strcmp(name, "once") && arity == 1) { return a0 && wamvm_vm_goal_supported_tr(a0, depth + 1); } if (!strcmp(name, "call") && arity == 1) { // Meta-call: only allow when the called goal is syntactically available and supported. return a0 && wamvm_vm_goal_supported_tr(a0, depth + 1); } if (!strcmp(name, ":") && arity == 2) { // Module qualification: validate only the qualified goal. return a1 && wamvm_vm_goal_supported_tr(a1, depth + 1); } if (!strcmp(name, "findall") && arity == 3) { // `findall/3` commonly passes a goal via a variable (e.g. count_solutions/2). // Allow this and validate at runtime (still enforces callable/type errors). if (!a1) { return false; } if (a1->tag == PL_TERM_VAR) { return true; } return wamvm_vm_goal_supported_tr(a1, depth + 1); } if (!strcmp(name, "catch") && arity == 3) { // Meta-call in Goal/1 and Recover/1 positions: ensure they are supported. if (!a0 || !a2) { return false; } return wamvm_vm_goal_supported_tr(a0, depth + 1) && wamvm_vm_goal_supported_tr(a2, depth + 1); } // User predicate (or a built-in we do not recognize here): allow. return true; } typedef struct { const CHR *context_name; // predicate containing the unsupported goal (or "") ULO context_arity; const CHR *goal_name; // unsupported goal functor/atom name ULO goal_arity; } pl_wamvm_support_info; static bool wamvm_vm_program_supported(pl_program *prog, const pl_query *q, pl_wamvm_support_info *out_info) { if (out_info) { memset(out_info, 0, sizeof(*out_info)); } if (!prog) { return false; } if (g_table_state) { return false; // tabling uses the WAM-lite path for now } for (ULO i = 1; i <= prog->clause_count; i++) { const pl_clause *cl = prog->clauses ? prog->clauses[i] : NULL; if (!cl) { continue; } for (ULO j = 1; j <= cl->body_count; j++) { const pl_term *g = cl->body ? cl->body[j] : NULL; if (g && !wamvm_vm_goal_supported_tr(g, 0)) { if (out_info) { out_info->context_name = ""; out_info->context_arity = 0; if (cl->head) { if (cl->head->tag == PL_TERM_ATOM) { out_info->context_name = cl->head->v.atom_name ? cl->head->v.atom_name : ""; out_info->context_arity = 0; } else if (cl->head->tag == PL_TERM_STRUCT) { out_info->context_name = cl->head->v.str.functor ? cl->head->v.str.functor : ""; out_info->context_arity = cl->head->v.str.arity; } } if (g->tag == PL_TERM_ATOM) { out_info->goal_name = g->v.atom_name ? g->v.atom_name : ""; out_info->goal_arity = 0; } else if (g->tag == PL_TERM_STRUCT) { out_info->goal_name = g->v.str.functor ? g->v.str.functor : ""; out_info->goal_arity = g->v.str.arity; } else if (g->tag == PL_TERM_VAR) { out_info->goal_name = ""; out_info->goal_arity = 0; } else { out_info->goal_name = ""; out_info->goal_arity = 0; } } return false; } } } if (q && q->goal_count) { for (ULO i = 1; i <= q->goal_count; i++) { const pl_term *g = q->goals ? q->goals[i] : NULL; if (g && !wamvm_vm_goal_supported_tr(g, 0)) { if (out_info) { out_info->context_name = ""; out_info->context_arity = 0; if (g->tag == PL_TERM_ATOM) { out_info->goal_name = g->v.atom_name ? g->v.atom_name : ""; out_info->goal_arity = 0; } else if (g->tag == PL_TERM_STRUCT) { out_info->goal_name = g->v.str.functor ? g->v.str.functor : ""; out_info->goal_arity = g->v.str.arity; } else if (g->tag == PL_TERM_VAR) { out_info->goal_name = ""; out_info->goal_arity = 0; } else { out_info->goal_name = ""; out_info->goal_arity = 0; } } return false; } } } return true; } static bool wamvm_vm_backtrack(pl_wamvm_vm *vm); static bool wamvm_vm_frame_has_live_choicepoints(const pl_wamvm_vm *vm, ULO frame_count) { if (!vm || !vm->cps || !vm->cp_count) { return false; } for (long i = (long)vm->cp_count - 1; i >= 0; i--) { const pl_wamvm_choicepoint *cp = &vm->cps[i]; if (cp->frame_count >= frame_count) { return true; } } return false; } static bool wamvm_goal_has_bound_scope_var(const pl_term *t, const pl_scope *scope, ULO depth) { if (!t || !scope) { return false; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return true; } t = term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { if (t->v.var.scope != scope) { return false; } pl_wam_cell *cell = wam_cell_for_var(t); return cell && cell->value; } if (t->tag == PL_TERM_PSTR) { const unsigned char *bytes = NULL; ULO len = 0; const pl_term *tail = NULL; if (term_pstr_run_bytes_len_tail_const(t, &bytes, &len, &tail) && tail) { return wamvm_goal_has_bound_scope_var(tail, scope, depth + 1); } return false; } if (t->tag != PL_TERM_STRUCT || !t->v.str.args) { return false; } for (ULO i = 0; i < t->v.str.arity; i++) { if (wamvm_goal_has_bound_scope_var(t->v.str.args[i], scope, depth + 1)) { return true; } } return false; } static inline bool wamvm_term_in_arena(const pl_term *t, const pl_term_arena *arena) { if (!t || !arena || !arena->terms || !arena->term_cap) { return false; } const uintptr_t p = (uintptr_t)t; const uintptr_t b = (uintptr_t)arena->terms; const uintptr_t e = b + (uintptr_t)arena->term_cap * sizeof(pl_term); return (p >= b) && (p < e); } static bool wamvm_term_contains_scope_var(const pl_term *t, const pl_scope *scope, ULO depth) { if (!t || !scope) { return false; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return true; } t = term_peel_pstr_empty_const(t); if (!t) { return false; } if (t->tag == PL_TERM_VAR) { return t->v.var.scope == scope; } if (t->tag == PL_TERM_PSTR) { const unsigned char *bytes = NULL; ULO len = 0; const pl_term *tail = NULL; if (term_pstr_run_bytes_len_tail_const(t, &bytes, &len, &tail) && tail) { return wamvm_term_contains_scope_var(tail, scope, depth + 1); } return false; } if (t->tag != PL_TERM_STRUCT || !t->v.str.args) { return false; } for (ULO i = 0; i < t->v.str.arity; i++) { if (wamvm_term_contains_scope_var(t->v.str.args[i], scope, depth + 1)) { return true; } } return false; } static pl_term *wamvm_tail_rewrite_goal(const pl_term *src, const pl_scope *scope, pl_term_arena *arena, const ULO *dbg_dat_ptr, ULO depth, bool *out_fail) { if (out_fail) { *out_fail = false; } if (!src || !scope) { return (pl_term *)src; } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { if (out_fail) { *out_fail = true; } return NULL; } src = term_peel_pstr_empty_const(src); if (!src) { return NULL; } if (wamvm_term_in_arena(src, arena)) { if (out_fail) { *out_fail = true; } return NULL; } if (src->tag == PL_TERM_PSTR) { const unsigned char *bytes = NULL; ULO len = 0; const pl_term *tail = NULL; if (term_pstr_run_bytes_len_tail_const(src, &bytes, &len, &tail) && tail) { if (wamvm_goal_has_bound_scope_var(tail, scope, depth + 1)) { if (out_fail) { *out_fail = true; } return NULL; } } return (pl_term *)src; } switch (src->tag) { case PL_TERM_ATOM: case PL_TERM_INT: case PL_TERM_FLOAT: case PL_TERM_BIGINT: return (pl_term *)src; case PL_TERM_VAR: { if (src->v.var.scope != scope) { return (pl_term *)src; } pl_wam_cell *cell = wam_cell_for_var(src); if (!cell || !cell->value) { return (pl_term *)src; } pl_term *val = deref_term_wam(cell->value); if (!val || (val == src)) { return (pl_term *)src; } if (wamvm_term_contains_scope_var(val, scope, depth + 1) || wamvm_term_in_arena(val, arena)) { if (out_fail) { *out_fail = true; } return NULL; } return val; } case PL_TERM_STRUCT: break; default: return (pl_term *)src; } if (!src->v.str.args || !src->v.str.arity) { return (pl_term *)src; } const ULO ar = src->v.str.arity; bool changed = false; pl_term **args = arena_alloc_args(arena, ar, dbg_dat_ptr); for (ULO i = 0; i < ar; i++) { pl_term *child = wamvm_tail_rewrite_goal(src->v.str.args[i], scope, arena, dbg_dat_ptr, depth + 1, out_fail); if (out_fail && *out_fail) { return NULL; } args[i] = child; if (child != src->v.str.args[i]) { changed = true; } } if (!changed) { arena->arg_pos -= ar; return (pl_term *)src; } pl_term *dst = arena_alloc_term(arena, dbg_dat_ptr); dst->tag = PL_TERM_STRUCT; dst->builtin = src->builtin; dst->reserved16 = src->reserved16; dst->v.str.arity = ar; dst->v.str.functor = src->v.str.functor; dst->v.str.args = args; return dst; } static bool wamvm_vm_try_call_pred(pl_wamvm_vm *vm, pl_wamvm_frame *frame, pl_term *goal, const CHR *pred_name, ULO pred_arity, bool tail_position, bool *out_defined, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (out_defined) { *out_defined = false; } if (!vm || !vm->prog || !vm->st || !frame || !goal || !pred_name) { return false; } if (g_wamvm_prof_nesting > 0) { g_wamvm_prof_pred_calls++; } // Keep compiled predicate code consistent with the current clause epoch so dynamic // database updates (asserta/retract/etc) are visible immediately. if (!g_wamvm_code || (g_wamvm_code->prog != vm->prog) || (g_wamvm_code->clause_epoch != atomic_load_explicit(&vm->prog->clause_epoch, memory_order_acquire))) { g_wamvm_code = wamvm_program_code_build(vm->prog, rt_ctrl, dbg_dat_ptr); } if (!g_wamvm_code) { return false; } const pl_wamvm_pred_code *pred = wamvm_code_find_pred(g_wamvm_code, pred_name, pred_arity); if (!pred) { // Predicate not present in the predicate index (likely truly undefined, but // consider dynamic/tabled declarations with zero clauses). if (prog_dyn_pred_contains(vm->prog, pred_name, pred_arity) || prog_tabled_pred_contains(vm->prog, pred_name, pred_arity)) { if (out_defined) { *out_defined = true; } if (g_wamvm_prof_nesting > 0) { g_wamvm_prof_pred_fail++; } return false; } // ISO-ish unknown procedure handling (prolog_flag unknown). if (vm->prog->flag_unknown == PL_UNKNOWN_WARNING) { streams_init(dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(2, &s, dbg_dat_ptr) || !s || !s->writable) { (void)fprintf(stderr, "Warning: unknown procedure: %s/%lu\n", pred_name, (unsigned long)pred_arity); } else { (void)fprintf(s->fp, "Warning: unknown procedure: %s/%lu\n", pred_name, (unsigned long)pred_arity); (void)fflush(s->fp); } } // For unknown=fail|warning, this is just failure. For unknown=error, the // caller raises existence_error. return false; } if (out_defined) { *out_defined = true; } if (!pred->clause_count || !pred->clauses) { return false; } // Shallow clause-head matchability precheck at call entry (helps avoid // creating useless choicepoints when only one clause head can ever match, // e.g. list base cases like `safe_(_, [], _)`). unsigned char matchable_local[PL_WAMVM_MATCHABLE_MAX]; unsigned char *matchable = NULL; const uint16_t match_mask = pred->matchable_arg_mask; if (match_mask && pred->clause_count && (pred->clause_count <= (ULO)PL_WAMVM_MATCHABLE_MAX)) { matchable = matchable_local; pl_term *gargs_local[PL_WAMVM_MATCHABLE_ARITY_MAX]; pl_term **gargs = NULL; ULO gargs_arity = 0; if (goal->tag == PL_TERM_STRUCT && goal->v.str.args) { const ULO ar = goal->v.str.arity; if (ar <= (ULO)PL_WAMVM_MATCHABLE_ARITY_MAX) { gargs = (pl_term **)gargs_local; gargs_arity = ar; for (ULO ai = 0; ai < ar; ai++) { gargs[ai] = (match_mask & (uint16_t)(1u << ai)) ? deref_term_wam(goal->v.str.args[ai]) : NULL; } } else { matchable = NULL; // avoid extra work for high-arity predicates } } else { matchable = NULL; } if (matchable) { for (ULO mi = 0; mi < pred->clause_count; mi++) { matchable[mi] = 1; const pl_clause *mcl = pred->clauses[mi].cl; if (!mcl || !mcl->head) { matchable[mi] = 0; continue; } if (goal->tag == PL_TERM_STRUCT && mcl->head->tag == PL_TERM_STRUCT && goal->v.str.args && mcl->head->v.str.args) { const ULO ar = goal->v.str.arity; if (ar != mcl->head->v.str.arity) { matchable[mi] = 0; continue; } if (gargs && gargs_arity != ar) { gargs = NULL; gargs_arity = 0; } for (ULO ai = 0; ai < ar; ai++) { if (!(match_mask & (uint16_t)(1u << ai))) { continue; } const pl_term *harg = mcl->head->v.str.args[ai]; if (!harg) { continue; } if (harg->tag == PL_TERM_VAR && harg->v.var.scope == mcl->scope) { continue; // clause var matches anything } pl_term *garg = gargs ? gargs[ai] : (goal->v.str.args ? deref_term_wam(goal->v.str.args[ai]) : NULL); if (!garg || garg->tag == PL_TERM_VAR) { continue; // goal var/unbound matches anything } if (harg->tag == PL_TERM_ATOM) { if (garg->tag != PL_TERM_ATOM) { matchable[mi] = 0; break; } const CHR *gname = garg->v.atom_name; const CHR *hname = harg->v.atom_name; if ((gname != hname) && (!gname || !hname || strcmp(gname, hname))) { matchable[mi] = 0; break; } continue; } if (harg->tag == PL_TERM_INT) { if (garg->tag != PL_TERM_INT || garg->v.int_value != harg->v.int_value) { matchable[mi] = 0; break; } continue; } if (harg->tag == PL_TERM_FLOAT) { if (garg->tag != PL_TERM_FLOAT || garg->v.float_value != harg->v.float_value) { matchable[mi] = 0; break; } continue; } if (harg->tag == PL_TERM_STRUCT) { if (garg->tag != PL_TERM_STRUCT || garg->v.str.arity != harg->v.str.arity) { matchable[mi] = 0; break; } const CHR *gfn = garg->v.str.functor; const CHR *hfn = harg->v.str.functor; if ((gfn != hfn) && (!gfn || !hfn || strcmp(gfn, hfn))) { matchable[mi] = 0; break; } continue; } // Foreign-scope variable or unknown tag: be conservative. } } } } } // New cut boundary for this predicate call (only when needed). const pl_wamvm_barrier *call_bar = frame->cut_barrier; if (pred->needs_cut_barrier) { pl_wamvm_barrier *b = (pl_wamvm_barrier *)pool_alloc(rt_ctrl, sizeof(*b), dbg_dat_ptr); *b = (pl_wamvm_barrier){.prev = frame->cut_barrier, .cp_base = vm->cp_count}; call_bar = b; } // Marks to restore when trying the next clause (logical update view within the call). const ULO call_trail = vm->st->trail.count; const ULO call_scope = vm->st->scope_count; pl_temp_mark call_tm = {0}; if (vm->release_temp) { call_tm = temp_alloc_mark(g_temp_alloc); } const bool trace_on = vm->prog && (vm->prog->flag_trace || vm->prog->flag_debug || vm->prog->flag_itrace); const bool allow_tail = tail_position && !trace_on && (frame->kind == PL_WAMVM_FRAME_CLAUSE) && !wamvm_vm_frame_has_live_choicepoints(vm, vm->frame_count); pl_wamvm_clause_frame *tail_cf = allow_tail ? frame->u.clause.cf : NULL; const pl_scope *tail_scope = tail_cf ? tail_cf->scope : NULL; const bool tail_scope_ok = allow_tail && tail_cf && tail_scope && (tail_scope->reserved == call_scope); const bool tail_bound = tail_scope_ok && wamvm_goal_has_bound_scope_var(goal, tail_scope, 0); for (ULO ci = 0; ci < pred->clause_count; ci++) { const pl_wamvm_clause_code *cc = &pred->clauses[ci]; const pl_clause *cl = cc ? cc->cl : NULL; if (!cl || !cl->head) { continue; } if (matchable && !matchable[ci]) { continue; } if (g_wamvm_prof_nesting > 0) { g_wamvm_prof_clause_attempts++; } // Ensure we are at the call entry state for this attempt. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, call_tm, rt_ctrl, dbg_dat_ptr); } bool need_cp = false; if (ci + 1 < pred->clause_count) { if (!matchable) { need_cp = true; } else { for (ULO mi = ci + 1; mi < pred->clause_count; mi++) { if (matchable[mi]) { need_cp = true; break; } } } } pl_term *call_goal = goal; pl_term *unify_goal = goal; pl_scope *scope = NULL; pl_wam_cell *cells = NULL; pl_term *vars = NULL; pl_term_arena arena = (pl_term_arena){0}; bool reuse_frame = false; if (tail_scope_ok && !need_cp && tail_cf && tail_scope) { pl_wam_scope_cells *sc = NULL; if (tail_scope->reserved && (tail_scope->reserved <= vm->st->scope_count) && vm->st->scopes) { sc = &vm->st->scopes[tail_scope->reserved - 1]; } const ULO scope_cap = sc ? sc->count : 0; const bool vars_ok = (cl->var_count == 0) || tail_cf->vars; const bool cells_ok = (cl->var_count == 0) || sc->cells; const bool scope_ok = sc && (sc->scope == tail_scope) && cells_ok && vars_ok && (scope_cap >= cl->var_count); const bool arena_ok = tail_cf->arena.terms && (tail_cf->arena.term_cap >= cl->tpl_nodes) && (tail_cf->arena.arg_cap >= cl->tpl_args); bool goal_in_arena = false; if (arena_ok && goal && tail_cf->arena.terms) { const uintptr_t g = (uintptr_t)goal; const uintptr_t b = (uintptr_t)tail_cf->arena.terms; const uintptr_t e = b + (uintptr_t)tail_cf->arena.term_cap * sizeof(pl_term); goal_in_arena = (g >= b) && (g < e); } const ULO inst_need = (cc && (cc->insn_count > 1)) ? cc->insn_count : 0; const bool inst_ok = !inst_need || (tail_cf->inst && (tail_cf->inst_cap >= inst_need)); if (scope_ok && arena_ok && inst_ok && !goal_in_arena) { scope = (pl_scope *)tail_scope; cells = sc->cells; vars = tail_cf->vars; if (cells && scope_cap) { memset(cells, 0, sizeof(*cells) * scope_cap); } if (vars && cl->var_count) { wamvm_vars_init(vars, cl->var_count, scope); } scope->var_count = scope_cap; wam_state_replace_top_scope_with_cells(vm->st, scope, cells, scope_cap); arena = tail_cf->arena; arena.term_pos = 0; arena.arg_pos = 0; reuse_frame = true; } } if (reuse_frame && tail_bound) { bool fail = false; pl_term *safe_goal = wamvm_tail_rewrite_goal(goal, tail_scope, &arena, dbg_dat_ptr, 0, &fail); if (fail || !safe_goal) { reuse_frame = false; scope = NULL; } else { unify_goal = safe_goal; } } if (!reuse_frame) { if (!wamvm_alloc_scope_cells_vars(vm->st, cl->var_count, &scope, &cells, &vars, rt_ctrl, dbg_dat_ptr)) { continue; } arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); } wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &vm->st->trail, rt_ctrl, dbg_dat_ptr); if (!wamvm_unify_against_clause_term(unify_goal, cl->head, cl->scope, vars, cl->var_count, &vm->st->trail, &arena, dbg_dat_ptr, 0)) { continue; } if (g_wamvm_prof_nesting > 0) { g_wamvm_prof_clause_matches++; } // Success: advance past the call goal in the current frame. const ULO pc_after = frame->pc + 1; frame->pc = pc_after; // If there are more clauses, keep a choicepoint to resume at the next clause. // When Prolog-style tracing is enabled, keep a choicepoint even for the // final clause so backtracking can emit REDO/FAIL ports consistently. if (need_cp || (vm->prog && vm->prog->flag_trace)) { wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *cp = &vm->cps[vm->cp_count++]; cp->kind = PL_WAMVM_CP_PRED_CLAUSE; cp->frame_count = vm->frame_count; cp->frame_pc = pc_after; cp->frame_cut_barrier = frame->cut_barrier; cp->frame_exc_barrier = frame->exc_barrier; cp->frame_depth = frame->depth; cp->trail_mark = call_trail; cp->scope_mark = call_scope; cp->tmp_mark = call_tm; cp->u.pred.call_goal = call_goal; cp->u.pred.pred = pred; cp->u.pred.next_ci = ci + 1; cp->u.pred.call_barrier = call_bar; cp->u.pred.had_exit = 0; wamvm_vm_cp_snapshot_capture(vm, cp); } // Push a clause body frame (bytecode) on top. pl_wamvm_frame *nf = NULL; if (reuse_frame) { nf = frame; } else { wamvm_vm_vec_reserve_frames(vm, vm->frame_count + 1); nf = &vm->frames[vm->frame_count++]; } nf->kind = PL_WAMVM_FRAME_CLAUSE; nf->depth = reuse_frame ? frame->depth : (frame->depth + 1); nf->cut_barrier = call_bar; nf->exc_barrier = frame->exc_barrier; nf->pc = 0; pl_term **inst = NULL; ULO inst_cap = 0; pl_wamvm_clause_frame *cf = NULL; if (cc && (cc->insn_count > 1)) { const ULO n = cc->insn_count; if (reuse_frame) { cf = nf->u.clause.cf; inst = cf ? cf->inst : NULL; inst_cap = cf ? cf->inst_cap : 0; if (inst && inst_cap) { memset(inst, 0, sizeof(*inst) * inst_cap); } } else { cf = (pl_wamvm_clause_frame *)pool_alloc(rt_ctrl, (ULO)(sizeof(*cf) + (size_t)n * sizeof(*inst)), dbg_dat_ptr); inst = (pl_term **)(cf + 1); inst_cap = n; memset(inst, 0, sizeof(*inst) * n); } } else { if (reuse_frame) { cf = nf->u.clause.cf; inst = cf ? cf->inst : NULL; inst_cap = cf ? cf->inst_cap : 0; } else { cf = (pl_wamvm_clause_frame *)pool_alloc(rt_ctrl, sizeof(*cf), dbg_dat_ptr); } } *cf = (pl_wamvm_clause_frame){ .code = cc, .cl = cl, .call_goal = call_goal, .scope = scope, .arena = arena, .vars = vars, .var_count = cl->var_count, .inst = inst, .inst_cap = inst_cap, }; nf->u.clause.cf = cf; return true; } // No clause matched: restore call entry marks. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, call_tm, rt_ctrl, dbg_dat_ptr); } if (g_wamvm_prof_nesting > 0) { g_wamvm_prof_pred_fail++; } return false; } // Forward declaration so meta-builtins (e.g. \+/1, findall/3) can recurse safely. static pl_cut_signal solve_goals_wamvm_cb(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_wam_cont *cont); static pl_term *wamvm_vm_select1_build_rest(pl_wamvm_vm *vm, const CHR *cons_functor, pl_term *const *prefix, size_t prefix_count, pl_term *tail) { pl_term *rest = tail; if (!vm || !prefix_count) { return rest; } const size_t align = sizeof(void *); const size_t term_bytes = prefix_count * sizeof(pl_term); const size_t term_bytes_aligned = (term_bytes + align - 1) & ~(align - 1); const size_t args_bytes = prefix_count * 2 * sizeof(pl_term *); const size_t total_bytes = term_bytes_aligned + args_bytes; void *mem = pool_alloc(vm->rt_ctrl, (ULO)total_bytes, vm->dbg_dat_ptr); pl_term *terms = (pl_term *)mem; pl_term **args = (pl_term **)((char *)mem + term_bytes_aligned); for (size_t i = prefix_count; i > 0; i--) { const size_t ci = prefix_count - i; pl_term *cons = &terms[ci]; cons->tag = PL_TERM_STRUCT; cons->builtin = 0; cons->reserved16 = 0; cons->v.str.arity = 2; cons->v.str.functor = (CHR *)(cons_functor ? cons_functor : "."); cons->v.str.args = &args[ci * 2]; cons->v.str.args[0] = prefix[i - 1]; cons->v.str.args[1] = rest; rest = cons; } return rest; } static const pl_clause *wamvm_vm_trace_clause(const pl_wamvm_vm *vm) { if (!vm || !vm->frames || !vm->frame_count) { return NULL; } for (long i = (long)vm->frame_count - 1; i >= 0; i--) { const pl_wamvm_frame *f = &vm->frames[i]; if (f->kind != PL_WAMVM_FRAME_CLAUSE) { continue; } const pl_wamvm_clause_frame *cf = f->u.clause.cf; if (cf && cf->cl) { return cf->cl; } } return NULL; } static void wamvm_vm_mark_pred_choicepoint_exit(pl_wamvm_vm *vm, pl_term *call_goal) { if (!vm || !call_goal || !vm->cps || !vm->cp_count) { return; } for (long i = (long)vm->cp_count - 1; i >= 0; i--) { pl_wamvm_choicepoint *cp = &vm->cps[i]; if (cp->kind != PL_WAMVM_CP_PRED_CLAUSE) { continue; } if (cp->u.pred.call_goal != call_goal) { continue; } cp->u.pred.had_exit = 1; return; } } static pl_cut_signal wamvm_vm_exec_goal(pl_wamvm_vm *vm, pl_wamvm_frame *frame, pl_term *raw_goal, bool tail_position, int *out_ok) { if (out_ok) { *out_ok = 0; } if (!vm || !vm->st || !frame || !raw_goal) { return cut_none(); } if (FLOWLOG_DEPTH_LIMIT_EXCEEDED(frame->depth, FLOWLOG_SOLVE_DEPTH_LIMIT)) { return cut_none(); } { const pl_clause *saved_clause = g_trace_clause; g_trace_clause = NULL; if (vm->prog && (vm->prog->flag_trace || vm->prog->flag_debug || vm->prog->flag_itrace)) { g_trace_clause = wamvm_vm_trace_clause(vm); } trace_record_goal_wam(vm->prog, raw_goal, frame->depth); g_trace_clause = saved_clause; } pl_term *goal = deref_term_wam_and_peel_pstr_empty(raw_goal); if (!goal) { return cut_none(); } // ISO: calling a variable goal is an instantiation error. if (goal->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } // ISO: calling a non-callable term is a type error. if (term_is_list_like_pair(goal) && !term_is_list_pair(goal)) { pl_term *h = NULL; pl_term *tail = NULL; if (!term_list_like_uncons_rt(goal, &h, &tail, vm->rt_ctrl, vm->dbg_dat_ptr) || !h || !tail) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, "call", 1); } pl_term *st = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ".", 2); st->v.str.args[0] = h; st->v.str.args[1] = tail; goal = st; } if (!term_is_callable_like(goal)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, "call", 1); } // Control constructs may appear without builtin ids; handle by functor/arity too. // // Performance note: most 2-arity goals are ordinary built-ins (is/2, =:=/2, // etc) that already have builtin ids. Avoid expensive string comparisons by // checking the cached builtin id first and only falling back to functor // matching when no id is present. if (goal->tag == PL_TERM_STRUCT && goal->v.str.args && goal->v.str.arity == 2) { const pl_builtin_id bid = (pl_builtin_id)goal->builtin; const CHR *fn = goal->v.str.functor; if ((bid == PL_BI_COMMA_2) || (!bid && fn && !strcmp(fn, ","))) { pl_term *g1 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); pl_term *g2 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!g1 || !g2) { return cut_none(); } if (g1->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(g1)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, ",", 2); } if ((g2->tag != PL_TERM_VAR) && !term_is_callable_like(g2)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, ",", 2); } // Consume the ',' goal and push G2 then G1 so G1 runs first. frame->pc++; wamvm_vm_push_frame_goal1(vm, g2, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); wamvm_vm_push_frame_goal1(vm, g1, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } if ((bid == PL_BI_ARROW_2) || (!bid && fn && !strcmp(fn, "->"))) { pl_term *if_goal = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); pl_term *then_goal = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!if_goal || !then_goal) { return cut_none(); } if (if_goal->tag == PL_TERM_VAR || then_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(if_goal)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, "->", 2); } if (!term_is_callable_like(then_goal)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, "->", 2); } // Probe the condition with a local cut barrier and commit to the first success. const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_temp_mark tm = {0}; if (vm->release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; g_wam_on_solution = NULL; g_wam_on_solution_ctx = NULL; pl_term *sub_goals[1] = {if_goal}; ULO inner_sol = 0; pl_wamvm_barrier inner_bar = {.prev = NULL, .cp_base = 0}; pl_cut_signal inner = solve_goals_wamvm_cb(vm->prog, vm->q, sub_goals, 1, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, true, NULL, &inner_sol, vm->rt_ctrl, vm->dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; if (inner.except) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; // IMPORTANT: do not release query-temporary allocations here. // The thrown exception term/environment may be allocated in the current // query temp arena; releasing to `tm` would invalidate it before an // outer catch/3 has a chance to unify the catcher. return inner; } if (inner.cut && (inner.target != &inner_bar)) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return inner; } if (!inner_sol) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); } // Condition succeeded: keep bindings and continue with Then. frame->pc++; wamvm_vm_push_frame_goal1(vm, then_goal, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } if ((bid == PL_BI_SEMI_2) || (!bid && fn && !strcmp(fn, ";"))) { pl_term *g1 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); pl_term *g2 = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!g1 || !g2) { return cut_none(); } if (g1->tag == PL_TERM_VAR || g2->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(g1)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, ";", 2); } if (!term_is_callable_like(g2)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, ";", 2); } // ISO if-then-else: (If -> Then ; Else) is parsed as ;(->(If,Then),Else). if ((g1->tag == PL_TERM_STRUCT) && (g1->v.str.arity == 2) && g1->v.str.args && (((pl_builtin_id)g1->builtin == PL_BI_ARROW_2) || (g1->v.str.functor && !strcmp(g1->v.str.functor, "->")))) { pl_term *if_goal = deref_term_wam_and_peel_pstr_empty(g1->v.str.args[0]); pl_term *then_goal = deref_term_wam_and_peel_pstr_empty(g1->v.str.args[1]); if (!if_goal || !then_goal) { return cut_none(); } if (if_goal->tag == PL_TERM_VAR || then_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(if_goal)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, ";", 2); } if (!term_is_callable_like(then_goal)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal, &empty, ";", 2); } const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_temp_mark tm = {0}; if (vm->release_temp) { tm = temp_alloc_mark(g_temp_alloc); } // Probe the If goal without leaking solutions into outer collectors. const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; g_wam_on_solution = NULL; g_wam_on_solution_ctx = NULL; pl_term *sub_goals[1] = {if_goal}; ULO inner_sol = 0; pl_wamvm_barrier inner_bar = {.prev = NULL, .cp_base = 0}; pl_cut_signal inner = solve_goals_wamvm_cb(vm->prog, vm->q, sub_goals, 1, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, true, NULL, &inner_sol, vm->rt_ctrl, vm->dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; if (inner.except) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return inner; } if (inner.cut && (inner.target != &inner_bar)) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return inner; } frame->pc++; if (!inner_sol) { // If failed: undo bindings and run Else. wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } wamvm_vm_push_frame_goal1(vm, g2, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); } else { // If succeeded: keep bindings and run Then (Else is not considered). wamvm_vm_push_frame_goal1(vm, then_goal, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); } if (out_ok) { *out_ok = 1; } return cut_none(); } // Choicepoint for the second branch. const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_temp_mark tm = {0}; if (vm->release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO pc_after = frame->pc + 1; frame->pc = pc_after; wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *cp = &vm->cps[vm->cp_count++]; memset(cp, 0, sizeof(*cp)); cp->kind = PL_WAMVM_CP_DISJ; cp->frame_count = vm->frame_count; cp->frame_pc = pc_after; cp->frame_cut_barrier = frame->cut_barrier; cp->frame_exc_barrier = frame->exc_barrier; cp->frame_depth = frame->depth; cp->trail_mark = mark_trail; cp->scope_mark = mark_scope; cp->tmp_mark = tm; cp->u.disj.g2 = g2; wamvm_vm_cp_snapshot_capture(vm, cp); // Explore the first branch first. wamvm_vm_push_frame_goal1(vm, g1, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } } // Built-ins with cached ids. if (goal->builtin) { switch ((pl_builtin_id)goal->builtin) { case PL_BI_TRUE_0: frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); case PL_BI_FAIL_0: case PL_BI_FALSE_0: return cut_none(); case PL_BI_REPEAT_0: { // repeat/0 always succeeds, and on backtracking succeeds again. const ULO pc_after = frame->pc + 1; wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *cp = &vm->cps[vm->cp_count++]; memset(cp, 0, sizeof(*cp)); cp->kind = PL_WAMVM_CP_REPEAT; cp->frame_count = vm->frame_count; cp->frame_pc = pc_after; cp->frame_cut_barrier = frame->cut_barrier; cp->frame_exc_barrier = frame->exc_barrier; cp->frame_depth = frame->depth; cp->trail_mark = vm->st->trail.count; cp->scope_mark = vm->st->scope_count; cp->tmp_mark = vm->release_temp ? temp_alloc_mark(g_temp_alloc) : (pl_temp_mark){0}; wamvm_vm_cp_snapshot_capture(vm, cp); frame->pc = pc_after; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_NL_0: { streams_init(vm->dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr) || !s->writable) { return cut_none(); } stream_write_char(s, id, '\n'); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_FLUSH_OUTPUT_0: { streams_init(vm->dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr) || !s->writable) { return cut_none(); } if (flowlog_capture_user_output_stream(id)) { stream_drain_user_output_capture_if_enabled(s, id, vm->rt_ctrl, vm->dbg_dat_ptr); } else { (void)fflush(s->fp); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_HALT_0: g_halt_requested = true; g_halt_code = 0; return cut_to(&g_halt_barrier); case PL_BI_CUT_0: { const pl_wamvm_barrier *b = frame->cut_barrier; wamvm_vm_cps_drop_to(vm, b ? b->cp_base : 0); if (b && vm->base_cut_barrier && (b == vm->base_cut_barrier)) { vm->cut_at_base = true; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_DROP_BARRIER_1: { if (!goal->v.str.args) { return cut_none(); } pl_term *bar = deref_term_wam(goal->v.str.args[0]); if (!bar || (bar->tag != PL_TERM_INT)) { return cut_none(); } frame->cut_barrier = (const pl_wamvm_barrier *)(uintptr_t)bar->v.int_value; frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_DROP_EXC_BARRIER_1: { if (!goal->v.str.args) { return cut_none(); } pl_term *bar = deref_term_wam(goal->v.str.args[0]); if (!bar || (bar->tag != PL_TERM_INT)) { return cut_none(); } frame->exc_barrier = (const void *)(uintptr_t)bar->v.int_value; frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_UNIFY_2: { if (!goal->v.str.args) { return cut_none(); } if (!unify_terms_wam(goal->v.str.args[0], goal->v.str.args[1], &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_NOT_UNIFY_2: { if (!goal->v.str.args) { return cut_none(); } const ULO mark = vm->st->trail.count; const bool ok = !unify_terms_wam(goal->v.str.args[0], goal->v.str.args[1], &vm->st->trail, vm->dbg_dat_ptr); wam_trail_unwind(&vm->st->trail, mark); if (!ok) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_IDENTICAL_2: case PL_BI_NOT_IDENTICAL_2: { if (!goal->v.str.args) { return cut_none(); } const int r = compare_std_terms_wam(goal->v.str.args[0], goal->v.str.args[1], vm->dbg_dat_ptr); const bool ok = ((pl_builtin_id)goal->builtin == PL_BI_IDENTICAL_2) ? (r == 0) : (r != 0); if (!ok) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_VARIANT_2: case PL_BI_NOT_VARIANT_2: { if (!goal->v.str.args) { return cut_none(); } const bool is_variant = term_variant_wam(goal->v.str.args[0], goal->v.str.args[1], vm->dbg_dat_ptr); const bool ok = ((pl_builtin_id)goal->builtin == PL_BI_VARIANT_2) ? is_variant : !is_variant; if (!ok) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_TERM_LT_2: case PL_BI_TERM_LTE_2: case PL_BI_TERM_GT_2: case PL_BI_TERM_GTE_2: { if (!goal->v.str.args) { return cut_none(); } const int r = compare_std_terms_wam(goal->v.str.args[0], goal->v.str.args[1], vm->dbg_dat_ptr); bool ok = false; switch ((pl_builtin_id)goal->builtin) { case PL_BI_TERM_LT_2: ok = (r < 0); break; case PL_BI_TERM_LTE_2: ok = (r <= 0); break; case PL_BI_TERM_GT_2: ok = (r > 0); break; case PL_BI_TERM_GTE_2: ok = (r >= 0); break; default: break; } if (!ok) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_IS_2: { if (!goal->v.str.args) { return cut_none(); } pl_number val = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex_wam(goal->v.str.args[1], &val, &aerr, 0, vm->rt_ctrl, vm->dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_env empty = {0}; pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "evaluable", pi, &empty, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_env empty = {0}; pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", cul, &empty, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_env empty = {0}; pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "float", cul, &empty, "is", 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "zero_divisor", "is", 2); } return throw_evaluation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "undefined", "is", 2); } pl_term *rhs = num_to_term_rt(val, vm->rt_ctrl, vm->dbg_dat_ptr); if (!unify_terms_wam(goal->v.str.args[0], rhs, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_NUM_EQ_2: case PL_BI_NUM_NE_2: case PL_BI_NUM_LT_2: case PL_BI_NUM_LTE_2: case PL_BI_NUM_GT_2: case PL_BI_NUM_GTE_2: { if (!goal->v.str.args) { return cut_none(); } pl_number a = {0}; pl_number b = {0}; const CHR *fn = goal->v.str.functor ? goal->v.str.functor : "compare"; pl_arith_error err = {0}; if (!eval_num_expr_ex_wam(goal->v.str.args[0], &a, &err, 0, vm->rt_ctrl, vm->dbg_dat_ptr)) { if (err.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (err.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_env empty = {0}; pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, err.evaluable_name ? err.evaluable_name : "", err.evaluable_arity); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "evaluable", pi, &empty, fn, 2); } if (err.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_env empty = {0}; pl_term *cul = (pl_term *)err.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[0]); } return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", cul, &empty, fn, 2); } if (err.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_env empty = {0}; pl_term *cul = (pl_term *)err.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[0]); } return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "float", cul, &empty, fn, 2); } if (err.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "undefined", fn, 2); } err = (pl_arith_error){0}; if (!eval_num_expr_ex_wam(goal->v.str.args[1], &b, &err, 0, vm->rt_ctrl, vm->dbg_dat_ptr)) { if (err.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (err.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_env empty = {0}; pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, err.evaluable_name ? err.evaluable_name : "", err.evaluable_arity); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "evaluable", pi, &empty, fn, 2); } if (err.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_env empty = {0}; pl_term *cul = (pl_term *)err.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", cul, &empty, fn, 2); } if (err.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_env empty = {0}; pl_term *cul = (pl_term *)err.culprit; if (!cul) { cul = deref_term_wam(goal->v.str.args[1]); } return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "float", cul, &empty, fn, 2); } if (err.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "zero_divisor", fn, 2); } return throw_evaluation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "undefined", fn, 2); } bool ok = false; if (!num_is_float(a) && !num_is_float(b)) { const int cmp = num_cmp(a, b); switch ((pl_builtin_id)goal->builtin) { case PL_BI_NUM_EQ_2: ok = (cmp == 0); break; case PL_BI_NUM_NE_2: ok = (cmp != 0); break; case PL_BI_NUM_LT_2: ok = (cmp < 0); break; case PL_BI_NUM_LTE_2: ok = (cmp <= 0); break; case PL_BI_NUM_GT_2: ok = (cmp > 0); break; case PL_BI_NUM_GTE_2: ok = (cmp >= 0); break; default: break; } } else { const double da = num_as_double(a); const double db = num_as_double(b); switch ((pl_builtin_id)goal->builtin) { case PL_BI_NUM_EQ_2: ok = (da == db); break; case PL_BI_NUM_NE_2: ok = (da != db); break; case PL_BI_NUM_LT_2: ok = (da < db); break; case PL_BI_NUM_LTE_2: ok = (da <= db); break; case PL_BI_NUM_GT_2: ok = (da > db); break; case PL_BI_NUM_GTE_2: ok = (da >= db); break; default: break; } } if (!ok) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } case PL_BI_NOT_1: { if (!goal->v.str.args || !goal->v.str.args[0]) { return cut_none(); } pl_term *sub_goal = deref_term_wam(goal->v.str.args[0]); if (!sub_goal) { return cut_none(); } if (sub_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if ((sub_goal->tag != PL_TERM_ATOM) && (sub_goal->tag != PL_TERM_STRUCT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", sub_goal, &empty, "\\+", 1); } const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_temp_mark tm = {0}; if (vm->release_temp) { tm = temp_alloc_mark(g_temp_alloc); } // \+/1 is a probe: do not let nested solutions leak into findall/bagof/setof collectors. const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; g_wam_on_solution = NULL; g_wam_on_solution_ctx = NULL; pl_term *sub_goals[1] = {sub_goal}; ULO inner_sol = 0; pl_wamvm_barrier inner_bar = {.prev = NULL, .cp_base = 0}; pl_cut_signal inner = solve_goals_wamvm_cb(vm->prog, vm->q, sub_goals, 1, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, true, NULL, &inner_sol, vm->rt_ctrl, vm->dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (inner.except) { // IMPORTANT: do not release query-temporary allocations here. // The thrown exception term/environment may be allocated in the current // query temp arena; releasing to `tm` would invalidate it before an // outer catch/3 has a chance to unify the catcher. return inner; } if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } if (inner.cut && (inner.target != &inner_bar)) { return inner; } if (inner_sol) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } default: break; } } // Some atom goals (arity 0) are not assigned builtin ids; handle them here. if (goal->tag == PL_TERM_ATOM && goal->v.atom_name) { if (!strcmp(goal->v.atom_name, "trace")) { if (vm->prog) { vm->prog->flag_trace = true; vm->prog->flag_debug = true; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(goal->v.atom_name, "notrace")) { if (vm->prog) { vm->prog->flag_trace = false; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(goal->v.atom_name, "itrace")) { if (vm->prog) { vm->prog->flag_itrace = true; vm->prog->flag_debug = true; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(goal->v.atom_name, "noitrace")) { if (vm->prog) { vm->prog->flag_itrace = false; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(goal->v.atom_name, "debug")) { if (vm->prog) { vm->prog->flag_debug = true; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(goal->v.atom_name, "nodebug")) { if (vm->prog) { vm->prog->flag_debug = false; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(goal->v.atom_name, "at_end_of_stream")) { streams_init(vm->dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(g_streams.current_input, &s, vm->dbg_dat_ptr) || !s->readable) { return cut_none(); } if (s->pushback_count) { return cut_none(); } const int c = fgetc(s->fp); if (c == EOF) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)c); return cut_none(); } if (!strcmp(goal->v.atom_name, "listing")) { streams_init(vm->dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { return cut_none(); } pl_env empty = {0}; if (!s->writable) { pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "listing", 0); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "listing", 0); } const pl_clause **snap = NULL; ULO snap_count = 0; if (vm->prog && vm->prog->clauses && vm->prog->clause_count) { prog_db_rlock(vm->prog); snap = (const pl_clause **)pool_alloc(vm->rt_ctrl, sizeof(*snap) * vm->prog->clause_count, vm->dbg_dat_ptr); for (ULO i = 1; i <= vm->prog->clause_count; i++) { const pl_clause *cl = vm->prog->clauses[i]; if (!cl || !cl->head) { continue; } snap[snap_count++] = cl; } prog_db_runlock(vm->prog); } for (ULO i = 0; i < snap_count; i++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = snap[i]; if (!cl || !cl->head) { continue; } pl_temp_mark m = {0}; const bool release_temp = (g_temp_alloc != NULL); if (release_temp) { m = temp_alloc_mark(g_temp_alloc); } pl_term *t = cl->head; if (cl->body_count && cl->body) { pl_term **body_goals = (pl_term **)pool_alloc(vm->rt_ctrl, sizeof(pl_term *) * cl->body_count, vm->dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = cl->body[bi + 1]; } pl_term *body_term = build_conjunction_rt(vm->rt_ctrl, vm->dbg_dat_ptr, body_goals, cl->body_count); pl_term *rule = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ":-", 2); rule->v.str.args[0] = cl->head; rule->v.str.args[1] = body_term; t = rule; } pl_sbuf sb; sbuf_init(&sb, vm->rt_ctrl, vm->dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false}; write_term_to_sbuf(vm->prog ? vm->prog->op_overrides : NULL, t, cl->env, &wopts, &sb, vm->dbg_dat_ptr); sbuf_append_char(&sb, '.'); sbuf_append_char(&sb, '\n'); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); if (release_temp) { temp_alloc_release(g_temp_alloc, m, vm->rt_ctrl, vm->dbg_dat_ptr); } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } } // Additional built-ins handled by name/arity (not assigned a builtin id). if (goal->tag == PL_TERM_STRUCT && goal->v.str.functor) { const CHR *fn = goal->v.str.functor; const ULO ar = goal->v.str.arity; if (!strcmp(fn, "var") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag == PL_TERM_VAR)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "nonvar") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag != PL_TERM_VAR)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "atom") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag == PL_TERM_ATOM)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "integer") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_integer(v)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "float") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && (v->tag == PL_TERM_FLOAT)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "number") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_number(v)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "atomic") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_atomic_term(v)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "compound") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_compound_like(v)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "callable") && (ar == 1) && goal->v.str.args) { pl_term *v = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (v && term_is_callable_like(v)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "ground") && (ar == 1) && goal->v.str.args) { pl_var_stack stv; var_stack_init(&stv); const bool ok = term_is_ground_wam_tr(goal->v.str.args[0], &stv, vm->dbg_dat_ptr, 0); var_stack_free(&stv); if (ok) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "acyclic_term") && (ar == 1) && goal->v.str.args) { pl_var_stack stv; var_stack_init(&stv); const bool ok = term_is_acyclic_wam_tr(goal->v.str.args[0], &stv, vm->dbg_dat_ptr, 0); var_stack_free(&stv); if (ok) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (!strcmp(fn, "once") && (ar == 1) && goal->v.str.args) { pl_term *sub_goal = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (!sub_goal) { return cut_none(); } if (sub_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(sub_goal)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", sub_goal, &empty, "once", 1); } const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_temp_mark tm = {0}; if (vm->release_temp) { tm = temp_alloc_mark(g_temp_alloc); } // once/1 is a probe: do not let nested solutions leak into all-solutions collectors. const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; g_wam_on_solution = NULL; g_wam_on_solution_ctx = NULL; pl_term *sub_goals[1] = {sub_goal}; ULO inner_sol = 0; pl_wamvm_barrier inner_bar = {.prev = NULL, .cp_base = 0}; pl_cut_signal inner = solve_goals_wamvm_cb(vm->prog, vm->q, sub_goals, 1, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, true, NULL, &inner_sol, vm->rt_ctrl, vm->dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; if (inner.except) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; // IMPORTANT: do not release query-temporary allocations here. // The thrown exception term/environment may be allocated in the current // query temp arena; releasing to `tm` would invalidate it before an // outer catch/3 has a chance to unify the catcher. return inner; } if (inner.cut && (inner.target != &inner_bar)) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return inner; } if (!inner_sol) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); } // Success: keep bindings from the inner VM run and continue. frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "catch") && (ar == 3) && goal->v.str.args) { pl_term *sub_goal = deref_term_wam(goal->v.str.args[0]); pl_term *recover_goal = deref_term_wam(goal->v.str.args[2]); if (!sub_goal || !recover_goal) { return cut_none(); } if (sub_goal->tag == PL_TERM_VAR || recover_goal->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if ((sub_goal->tag != PL_TERM_ATOM) && (sub_goal->tag != PL_TERM_STRUCT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", sub_goal, &empty, "catch", 3); } if ((recover_goal->tag != PL_TERM_ATOM) && (recover_goal->tag != PL_TERM_STRUCT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", recover_goal, &empty, "catch", 3); } // Local exception barrier for Goal execution. int *local_exc = (int *)pool_alloc(vm->rt_ctrl, sizeof(*local_exc), vm->dbg_dat_ptr); *local_exc = 0; // Install an exception handler choicepoint for catch/3. wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *cp = &vm->cps[vm->cp_count++]; memset(cp, 0, sizeof(*cp)); cp->kind = PL_WAMVM_CP_CATCH; cp->frame_count = vm->frame_count; cp->frame_pc = frame->pc + 1; cp->frame_cut_barrier = frame->cut_barrier; cp->frame_exc_barrier = frame->exc_barrier; cp->frame_depth = frame->depth; cp->trail_mark = vm->st->trail.count; cp->scope_mark = vm->st->scope_count; cp->tmp_mark = vm->release_temp ? temp_alloc_mark(g_temp_alloc) : (pl_temp_mark){0}; cp->u.catch.local_exc = (const void *)local_exc; cp->u.catch.outer_exc = frame->exc_barrier; cp->u.catch.catcher = goal->v.str.args[1]; cp->u.catch.recover = recover_goal; wamvm_vm_cp_snapshot_capture(vm, cp); // ISO-ish: catch/3 introduces a call-local cut boundary (like call/1). pl_wamvm_barrier *catch_bar = (pl_wamvm_barrier *)pool_alloc(vm->rt_ctrl, sizeof(*catch_bar), vm->dbg_dat_ptr); *catch_bar = (pl_wamvm_barrier){.prev = frame->cut_barrier, .cp_base = vm->cp_count}; cp->u.catch.cut_barrier = catch_bar; // Advance past catch/3 and execute Goal in a fresh exception barrier context. frame->pc++; wamvm_vm_push_frame_goal1(vm, sub_goal, catch_bar, local_exc, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "throw") && (ar == 1) && goal->v.str.args) { pl_term *t = deref_term_wam(goal->v.str.args[0]); if (!t) { return cut_none(); } if (t->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "nonvar"); } pl_env *exc_env = alloc_empty_env_rt(vm->rt_ctrl, vm->dbg_dat_ptr); pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = vm->rt_ctrl; cctx.dbg_dat_ptr = vm->dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *copy = copy_term_wam_tr(goal->v.str.args[0], &cctx, 0); if (!copy) { copy_var_map_free(&cctx.map); free(cctx.bindings); return cut_none(); } const ULO nvars = cctx.map.next_var_id; if (cctx.bindings && nvars) { for (ULO i = 0; i < nvars && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { env_bind(exc_env, vm->rt_ctrl, vm->dbg_dat_ptr, scope, i, cctx.bindings[i]); } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; return except_to(frame->exc_barrier, copy, exc_env); } if (!strcmp(fn, "call") && (ar == 1) && goal->v.str.args) { pl_term *call_term = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (!call_term) { return cut_none(); } if (call_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(call_term)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", call_term, &empty, "call", 1); } // call/1 introduces a new cut boundary. pl_wamvm_barrier *call_bar = (pl_wamvm_barrier *)pool_alloc(vm->rt_ctrl, sizeof(*call_bar), vm->dbg_dat_ptr); *call_bar = (pl_wamvm_barrier){.prev = frame->cut_barrier, .cp_base = vm->cp_count}; frame->pc++; wamvm_vm_push_frame_goal1(vm, call_term, call_bar, frame->exc_barrier, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, ":") && (ar == 2) && goal->v.str.args) { pl_term *qual_goal = deref_term_wam(goal->v.str.args[1]); if (!qual_goal) { return cut_none(); } // Defer ISO meta-call errors (e.g., instantiation_error(callable)) to call/1. pl_term *call_goal = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "call", 1); call_goal->v.str.args[0] = qual_goal; frame->pc++; wamvm_vm_push_frame_goal1(vm, call_goal, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "call") && (ar >= 2) && (ar <= 8) && goal->v.str.args) { pl_term *closure = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (!closure) { return cut_none(); } if (closure->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(closure)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", closure, &empty, "call", ar); } pl_term *module_term = NULL; pl_term *base = closure; if ((closure->tag == PL_TERM_STRUCT) && closure->v.str.functor && !strcmp(closure->v.str.functor, ":") && (closure->v.str.arity == 2) && closure->v.str.args) { module_term = deref_term_wam(closure->v.str.args[0]); base = deref_term_wam_and_peel_pstr_empty(closure->v.str.args[1]); if (!base) { return cut_none(); } if (base->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (!term_is_callable_like(base)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", base, &empty, "call", ar); } } const ULO extra_n = ar - 1; pl_term *expanded = NULL; if (base->tag == PL_TERM_ATOM) { expanded = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, base->v.atom_name, extra_n); for (ULO i = 0; i < extra_n; i++) { expanded->v.str.args[i] = deref_term_wam(goal->v.str.args[i + 1]); } } else { pl_term *fname = NULL; SLO base_arity = 0; if (!term_functor_arity_rt(base, &fname, &base_arity, vm->rt_ctrl, vm->dbg_dat_ptr) || !fname || (fname->tag != PL_TERM_ATOM) || (base_arity <= 0)) { return cut_none(); } expanded = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, fname->v.atom_name, (ULO)base_arity + extra_n); for (SLO i = 0; i < base_arity; i++) { pl_term *argi = NULL; if (!term_compound_arg_rt(base, i + 1, &argi, vm->rt_ctrl, vm->dbg_dat_ptr) || !argi) { return cut_none(); } expanded->v.str.args[i] = deref_term_wam(argi); } for (ULO i = 0; i < extra_n; i++) { expanded->v.str.args[(ULO)base_arity + i] = deref_term_wam(goal->v.str.args[i + 1]); } } if (!expanded) { return cut_none(); } pl_term *call_goal = expanded; if (module_term) { pl_term *qual = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ":", 2); qual->v.str.args[0] = module_term; qual->v.str.args[1] = expanded; call_goal = qual; } // call/N introduces a new cut boundary. pl_wamvm_barrier *call_bar = (pl_wamvm_barrier *)pool_alloc(vm->rt_ctrl, sizeof(*call_bar), vm->dbg_dat_ptr); *call_bar = (pl_wamvm_barrier){.prev = frame->cut_barrier, .cp_base = vm->cp_count}; frame->pc++; wamvm_vm_push_frame_goal1(vm, call_goal, call_bar, frame->exc_barrier, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "unify_with_occurs_check") && (ar == 2) && goal->v.str.args) { if (!unify_terms_wam_occurs(goal->v.str.args[0], goal->v.str.args[1], &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "subsumes_term") && (ar == 2) && goal->v.str.args) { pl_term *pair = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "$subsumes_pair", 2); pair->v.str.args[0] = goal->v.str.args[0]; pair->v.str.args[1] = goal->v.str.args[1]; const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = vm->rt_ctrl; cctx.dbg_dat_ptr = vm->dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *pair_c = copy_term_wam_tr(pair, &cctx, 0); if (!pair_c || (pair_c->tag != PL_TERM_STRUCT) || strcmp(pair_c->v.str.functor, "$subsumes_pair") || (pair_c->v.str.arity != 2) || !pair_c->v.str.args) { copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; return cut_none(); } const ULO var_count = cctx.map.next_var_id; pl_wam_cell *cells = NULL; if (var_count) { cells = wam_state_push_scope(vm->st, scope, var_count, vm->rt_ctrl, vm->dbg_dat_ptr); if (cells && cctx.bindings) { for (ULO i = 0; i < var_count && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { cells[i].value = cctx.bindings[i]; } } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; pl_term *gen = pair_c->v.str.args[0]; pl_term *spec = pair_c->v.str.args[1]; if (!gen || !spec) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; return cut_none(); } pl_var_stack stv; pl_var_list rigid; var_stack_init(&stv); var_list_init(&rigid); term_collect_vars_wam_tr(spec, &stv, &rigid, vm->dbg_dat_ptr, 0); var_stack_free(&stv); const bool ok = unify_terms_subsumes_wam_tr(gen, spec, &vm->st->trail, &rigid, vm->rt_ctrl, vm->dbg_dat_ptr, 0); var_list_free(&rigid); wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (!ok) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "term_variables") && (ar == 2) && goal->v.str.args) { // Validate output argument is list/partial list. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term_wam(out0); if (!out_term) { return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", out0, &empty, "term_variables", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(vm->dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "term_variables", 2); } } } pl_var_stack stv; pl_var_list vl; var_stack_init(&stv); var_list_init(&vl); term_collect_vars_wam_tr(goal->v.str.args[0], &stv, &vl, vm->dbg_dat_ptr, 0); var_stack_free(&stv); pl_term *list = NULL; if (!vl.count) { list = make_nil_rt(vm->dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * vl.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } for (ULO i = 0; i < vl.count; i++) { elems[i] = vl.items[i].term; } list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, elems, vl.count); free(elems); } var_list_free(&vl); if (!unify_terms_wam(goal->v.str.args[1], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "copy_term") && (ar == 2) && goal->v.str.args) { const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = vm->rt_ctrl; cctx.dbg_dat_ptr = vm->dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); pl_term *copied = copy_term_wam_tr(goal->v.str.args[0], &cctx, 0); pl_wam_cell *cells = NULL; const ULO var_count = cctx.map.next_var_id; if (var_count) { cells = wam_state_push_scope(vm->st, scope, var_count, vm->rt_ctrl, vm->dbg_dat_ptr); if (cells && cctx.bindings) { for (ULO i = 0; i < var_count && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { cells[i].value = cctx.bindings[i]; } } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; if (!copied || !unify_terms_wam(goal->v.str.args[1], copied, &vm->st->trail, vm->dbg_dat_ptr)) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "numbervars") && (ar == 3) && goal->v.str.args) { pl_term *start_term = deref_term_wam(goal->v.str.args[1]); if (!start_term || (start_term->tag == PL_TERM_VAR)) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (start_term->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", start_term, &empty, "numbervars", 3); } pl_term *end_term = deref_term_wam(goal->v.str.args[2]); if (end_term && (end_term->tag != PL_TERM_VAR) && (end_term->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", end_term, &empty, "numbervars", 3); } const ULO mark = vm->st->trail.count; SLO counter = start_term->v.int_value; pl_var_stack stv; var_stack_init(&stv); const bool ok = term_numbervars_wam_tr(goal->v.str.args[0], &stv, &counter, &vm->st->trail, vm->rt_ctrl, vm->dbg_dat_ptr, 0); var_stack_free(&stv); if (!ok) { wam_trail_unwind(&vm->st->trail, mark); return cut_none(); } pl_term *end_val = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, counter); if (!unify_terms_wam(goal->v.str.args[2], end_val, &vm->st->trail, vm->dbg_dat_ptr)) { wam_trail_unwind(&vm->st->trail, mark); return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "=..") && (ar == 2) && goal->v.str.args) { pl_term *t = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (t && (t->tag != PL_TERM_VAR)) { // Validate list argument is a (proper or partial) list. pl_term *list0 = goal->v.str.args[1]; pl_term *list_term = deref_term_wam(list0); if (!list_term) { return cut_none(); } if (list_term->tag != PL_TERM_VAR) { pl_term *cur = list_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", list0, &empty, "=..", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(vm->dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "=..", 2); } } } pl_term *list = NULL; if (term_is_compound_like(t)) { pl_term *fname = NULL; SLO arity_val = 0; if (!term_functor_arity_rt(t, &fname, &arity_val, vm->rt_ctrl, vm->dbg_dat_ptr) || !fname || (fname->tag != PL_TERM_ATOM) || (arity_val < 0)) { return cut_none(); } const ULO n = (ULO)arity_val; pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * (n + 1)); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } elems[0] = fname; for (ULO i = 0; i < n; i++) { pl_term *argi = NULL; if (!term_compound_arg_rt(t, (SLO)i + 1, &argi, vm->rt_ctrl, vm->dbg_dat_ptr) || !argi) { free(elems); return cut_none(); } elems[i + 1] = argi; } list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, elems, n + 1); free(elems); } else { pl_term *elems[1] = {t}; list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, elems, 1); } if (!unify_terms_wam(goal->v.str.args[1], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Construct term from list. pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &v, vm->dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st_list == PL_LIST_STATUS_TYPE_ERROR || (v.count == 0)) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[1], &empty, "=..", 2); } pl_term *head = deref_term_wam(v.items[0]); if (!head) { term_vec_free(&v); return cut_none(); } if (head->tag == PL_TERM_VAR) { term_vec_free(&v); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_term *res = NULL; if (v.count == 1) { if (head->tag != PL_TERM_ATOM && head->tag != PL_TERM_INT && head->tag != PL_TERM_FLOAT) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atomic", head, &empty, "=..", 2); } res = head; } else { if (head->tag != PL_TERM_ATOM) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", head, &empty, "=..", 2); } const ULO n = v.count - 1; if (n > 255) { term_vec_free(&v); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "max_arity", "=..", 2); } pl_term *stt = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, head->v.atom_name, n); for (ULO i = 0; i < n; i++) { stt->v.str.args[i] = v.items[i + 1]; } res = stt; } term_vec_free(&v); if (!unify_terms_wam(goal->v.str.args[0], res, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "functor") && (ar == 3) && goal->v.str.args) { pl_term *t = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[0]); if (t && (t->tag != PL_TERM_VAR)) { pl_term *name = NULL; SLO arity_val = 0; if (!term_functor_arity_rt(t, &name, &arity_val, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } pl_term *arity_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, arity_val); if (!unify_terms_wam(goal->v.str.args[1], name, &vm->st->trail, vm->dbg_dat_ptr) || !unify_terms_wam(goal->v.str.args[2], arity_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Construct a term from Name/Arity. pl_term *name = deref_term_wam(goal->v.str.args[1]); pl_term *arity_term = deref_term_wam(goal->v.str.args[2]); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (arity_term->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", arity_term, &empty, "functor", 3); } const SLO n = arity_term->v.int_value; if (n < 0) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "functor", 3); } const SLO max_arity = 255; // current_prolog_flag(max_arity, 255) if (n > max_arity) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "max_arity", "functor", 3); } if (name->tag != PL_TERM_ATOM && name->tag != PL_TERM_INT && name->tag != PL_TERM_FLOAT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atomic", name, &empty, "functor", 3); } if (n == 0) { if (!unify_terms_wam(goal->v.str.args[0], name, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (name->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", name, &empty, "functor", 3); } const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); (void)wam_state_push_scope(vm->st, scope, (ULO)n, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *ct = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, name->v.atom_name, (ULO)n); for (ULO i = 0; i < (ULO)n; i++) { ct->v.str.args[i] = make_fresh_var_rt(vm->rt_ctrl, vm->dbg_dat_ptr, scope, i); } if (!unify_terms_wam(goal->v.str.args[0], ct, &vm->st->trail, vm->dbg_dat_ptr)) { wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Atom / character / number conversions (ISO core, integers + floats). if (!strcmp(fn, "char_code") && (ar == 2) && goal->v.str.args) { pl_term *ch = deref_term_wam(goal->v.str.args[0]); pl_term *code = deref_term_wam(goal->v.str.args[1]); if (!ch || !code) { return cut_none(); } if ((ch->tag == PL_TERM_VAR) && (code->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "char_code", 2); } if (ch->tag != PL_TERM_VAR) { if (ch->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", ch, &empty, "char_code", 2); } if (!atom_is_char(ch)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", ch, &empty, "char_code", 2); } } if (code->tag != PL_TERM_VAR && code->tag != PL_TERM_INT && code->tag != PL_TERM_BIGINT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", code, &empty, "char_code", 2); } SLO code_value = 0; if (code->tag == PL_TERM_INT) { code_value = code->v.int_value; } else if (code->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(code->v.bigint, &code_value)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", "char_code", 2); } } if (code->tag != PL_TERM_VAR) { if (code_value <= 0 || !unicode_codepoint_valid((uint32_t)code_value)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", "char_code", 2); } } if ((ch->tag == PL_TERM_VAR) && (code->tag != PL_TERM_VAR)) { pl_term *ct = make_char_atom_rt(vm->dbg_dat_ptr, (uint32_t)code_value); if (!unify_terms_wam(goal->v.str.args[0], ct, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if ((code->tag == PL_TERM_VAR) && (ch->tag == PL_TERM_ATOM)) { uint32_t cp = 0; if (!atom_codepoint(ch, &cp)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", ch, &empty, "char_code", 2); } pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)cp); if (!unify_terms_wam(goal->v.str.args[1], it, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if ((ch->tag == PL_TERM_ATOM) && (code->tag != PL_TERM_VAR)) { uint32_t cp = 0; if (!atom_codepoint(ch, &cp) || ((SLO)cp != code_value)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } return cut_none(); } if (!strcmp(fn, "atom_length") && (ar == 2) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", a, &empty, "atom_length", 2); } pl_term *len_in = deref_term_wam(goal->v.str.args[1]); if (len_in && (len_in->tag != PL_TERM_VAR) && (len_in->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", len_in, &empty, "atom_length", 2); } const SLO len = (SLO)strlen(a->v.atom_name ? a->v.atom_name : ""); pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, len); if (!unify_terms_wam(goal->v.str.args[1], it, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if ((!strcmp(fn, "atom_chars") || !strcmp(fn, "atom_codes")) && (ar == 2) && goal->v.str.args) { const bool use_codes = !strcmp(fn, "atom_codes"); pl_term *a = deref_term_wam(goal->v.str.args[0]); pl_term *l = deref_term_wam(goal->v.str.args[1]); if (!a || !l) { return cut_none(); } if ((a->tag == PL_TERM_VAR) && (l->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } if ((a->tag != PL_TERM_VAR) && (a->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", a, &empty, fn, 2); } if (a->tag == PL_TERM_ATOM) { // ISO: validate List is a proper/partial list and that nonvar elements have the right type. pl_term *l_chk = (pl_term *)term_peel_pstr_empty_const(l); if ((l_chk->tag != PL_TERM_VAR) && !term_is_nil(l_chk) && !term_is_list_like_pair(l_chk)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", l_chk, &empty, fn, 2); } if (l->tag != PL_TERM_VAR) { pl_term *cur = goal->v.str.args[1]; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (term_is_list_like_pair(cur) && !term_is_list_pair(cur)) { pl_env empty = {0}; if (use_codes) { const pl_term *h = NULL; const pl_term *t = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term tail_tmp = {0}; if (!term_list_like_uncons_view(cur, &h, &t, &head_tmp, head_ch, &tail_tmp) || !h || !h->v.atom_name) { return cut_none(); } uint32_t hcp = 0; if (!atom_codepoint(h, &hcp)) { hcp = PL_UTF8_REPLACEMENT; } pl_term *culprit = make_char_atom_rt(vm->dbg_dat_ptr, hcp); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(vm->dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", fn, 2); } continue; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag != PL_TERM_VAR) { if (use_codes) { if (h->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", h, &empty, fn, 2); } } else { if (!atom_is_char(h)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", h, &empty, fn, 2); } } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", fn, 2); } } } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); pl_term *list = NULL; if (use_codes) { pl_term *tail = make_nil_rt(vm->dbg_dat_ptr); for (size_t i = n; i > 0; i--) { pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)(unsigned char)s[i - 1]); pl_term *cons = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ".", 2); cons->v.str.args[0] = it; cons->v.str.args[1] = tail; tail = cons; } list = tail; } else { list = make_pstr_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (const unsigned char *)s, (ULO)n, make_nil_rt(vm->dbg_dat_ptr)); } if (!unify_terms_wam(goal->v.str.args[1], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Construct atom from list. if (l->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } if ((l->tag == PL_TERM_PSTR) || term_is_nil(l)) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_wam(goal->v.str.args[1], &pstr_cstr, &pstr_len, &pstr_buf, vm->dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (use_codes && (pstr_len > 0)) { uint32_t cp = 0; (void)utf8_decode_one_lenient(pstr_cstr, (size_t)pstr_len, &cp); if (pstr_buf) { free(pstr_buf); } pl_env empty = {0}; pl_term *culprit = make_char_atom_rt(vm->dbg_dat_ptr, cp); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } pl_term *at = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (const CHR *)pstr_cstr); if (pstr_buf) { free(pstr_buf); } if (!unify_terms_wam(goal->v.str.args[0], at, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (pst == PL_PSTR_CSTR_INSTANTIATION) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } } pl_term_vec elems = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &elems, vm->dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term_wam(elems.items[i]); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", e, &empty, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", e, &empty, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } buf[off] = '\0'; term_vec_free(&elems); pl_term *at = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, buf); free(buf); if (!unify_terms_wam(goal->v.str.args[0], at, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if ((!strcmp(fn, "number_chars") || !strcmp(fn, "number_codes")) && (ar == 2) && goal->v.str.args) { const bool use_codes = !strcmp(fn, "number_codes"); pl_term *n = deref_term_wam(goal->v.str.args[0]); pl_term *l = deref_term_wam(goal->v.str.args[1]); if (!n || !l) { return cut_none(); } if ((n->tag == PL_TERM_VAR) && (l->tag == PL_TERM_VAR)) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } if ((n->tag != PL_TERM_VAR) && (n->tag != PL_TERM_INT) && (n->tag != PL_TERM_BIGINT) && (n->tag != PL_TERM_FLOAT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "number", n, &empty, fn, 2); } // If Number is given, accept any List that parses to the same number. // For partial lists (variables in the list), unify with the canonical list. if (n->tag != PL_TERM_VAR) { bool has_var = false; // ISO: validate List is a proper/partial list and that nonvar elements have the right type. pl_term *l_chk = (pl_term *)term_peel_pstr_empty_const(l); if ((l_chk->tag != PL_TERM_VAR) && !term_is_nil(l_chk) && !term_is_list_like_pair(l_chk)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", l_chk, &empty, fn, 2); } if (l->tag != PL_TERM_VAR) { pl_term *cur = goal->v.str.args[1]; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { has_var = true; break; } if (term_is_list_like_pair(cur) && !term_is_list_pair(cur)) { pl_env empty = {0}; if (use_codes) { const pl_term *h = NULL; const pl_term *t = NULL; pl_term head_tmp = {0}; CHR head_ch[PL_UTF8_MAX_BYTES + 1] = {0}; pl_term tail_tmp = {0}; if (!term_list_like_uncons_view(cur, &h, &t, &head_tmp, head_ch, &tail_tmp) || !h || !h->v.atom_name) { return cut_none(); } uint32_t hcp = 0; if (!atom_codepoint(h, &hcp)) { hcp = PL_UTF8_REPLACEMENT; } pl_term *culprit = make_char_atom_rt(vm->dbg_dat_ptr, hcp); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(vm->dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", fn, 2); } continue; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag == PL_TERM_VAR) { has_var = true; } else { if (use_codes) { SLO code = 0; if (h->tag == PL_TERM_INT) { code = h->v.int_value; } else if (h->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(h->v.bigint, &code)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } } else { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", h, &empty, fn, 2); } if ((code < 0) || (code > 255)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } } else { if (!atom_is_char(h)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", h, &empty, fn, 2); } } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", fn, 2); } } } if ((l->tag != PL_TERM_VAR) && !has_var) { pl_parsed_number pn = {0}; bool parsed = false; if (!use_codes && ((l->tag == PL_TERM_PSTR) || term_is_nil(l))) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_wam(goal->v.str.args[1], &pstr_cstr, &pstr_len, &pstr_buf, vm->dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (!parse_number_iso_cstr((const CHR *)pstr_cstr, &pn, vm->rt_ctrl, vm->dbg_dat_ptr)) { if (pstr_buf) { free(pstr_buf); } return throw_syntax_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "illegal_number", fn, 2); } if (pstr_buf) { free(pstr_buf); } parsed = true; } } if (!parsed) { pl_term_vec elems = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &elems, vm->dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); has_var = true; } else if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } else { const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term_wam(elems.items[i]); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); has_var = true; break; } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", e, &empty, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", e, &empty, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } if (!has_var) { buf[off] = '\0'; term_vec_free(&elems); if (!parse_number_iso_cstr(buf, &pn, vm->rt_ctrl, vm->dbg_dat_ptr)) { free(buf); return throw_syntax_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "illegal_number", fn, 2); } free(buf); } } } if (!has_var) { if (!pn.is_float) { if ((n->tag == PL_TERM_INT) && !pn.is_big && (n->v.int_value == pn.ival)) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (n->tag == PL_TERM_BIGINT) { const int cmp = pn.is_big ? bigint_cmp(n->v.bigint, pn.big) : bigint_cmp_slo(n->v.bigint, pn.ival); if (cmp == 0) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } } } else if ((n->tag == PL_TERM_FLOAT) && (n->v.float_value == pn.fval)) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } return cut_none(); } } // Unify canonical list with List (variables/partial lists). const char *tmp = NULL; char ibuf[64]; char fbuf[128]; char *big_buf = NULL; if (n->tag == PL_TERM_INT) { (void)snprintf(ibuf, sizeof(ibuf), "%ld", (long)n->v.int_value); tmp = ibuf; } else if (n->tag == PL_TERM_BIGINT) { big_buf = bigint_to_cstr(n->v.bigint); if (!big_buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } tmp = big_buf; } else { float_to_cstr(n->v.float_value, fbuf, sizeof(fbuf)); tmp = fbuf; } const CHR *s = (const CHR *)(tmp ? tmp : ""); const size_t len = strlen(s); pl_term *list = NULL; if (use_codes) { pl_term *tail = make_nil_rt(vm->dbg_dat_ptr); for (size_t i = len; i > 0; i--) { pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)(unsigned char)s[i - 1]); pl_term *cons = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ".", 2); cons->v.str.args[0] = it; cons->v.str.args[1] = tail; tail = cons; } list = tail; } else { list = make_pstr_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (const unsigned char *)s, (ULO)len, make_nil_rt(vm->dbg_dat_ptr)); } if (big_buf) { free(big_buf); } if (!unify_terms_wam(goal->v.str.args[1], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Parse number from List. if ((l->tag == PL_TERM_PSTR) || term_is_nil(l)) { const unsigned char *pstr_cstr = NULL; ULO pstr_len = 0; unsigned char *pstr_buf = NULL; const pl_pstr_cstr_status pst = pstr_list_to_cstr_wam(goal->v.str.args[1], &pstr_cstr, &pstr_len, &pstr_buf, vm->dbg_dat_ptr); if (pstr_cstr_status_ok(pst)) { if (use_codes && (pstr_len > 0)) { uint32_t cp = 0; (void)utf8_decode_one_lenient(pstr_cstr, (size_t)pstr_len, &cp); if (pstr_buf) { free(pstr_buf); } pl_env empty = {0}; pl_term *culprit = make_char_atom_rt(vm->dbg_dat_ptr, cp); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", culprit, &empty, fn, 2); } pl_parsed_number pn = {0}; if (!parse_number_iso_cstr((const CHR *)pstr_cstr, &pn, vm->rt_ctrl, vm->dbg_dat_ptr)) { if (pstr_buf) { free(pstr_buf); } return throw_syntax_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "illegal_number", fn, 2); } if (pstr_buf) { free(pstr_buf); } pl_term *num = pn.is_float ? make_float_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pn.fval) : (pn.is_big ? make_bigint_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pn.big) : make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pn.ival)); if (!unify_terms_wam(goal->v.str.args[0], num, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (pst == PL_PSTR_CSTR_INSTANTIATION) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } } pl_term_vec elems = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[1], &elems, vm->dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&elems); return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[1], &empty, fn, 2); } const size_t cap = use_codes ? ((size_t)elems.count + 1) : ((size_t)elems.count * PL_UTF8_MAX_BYTES + 1); CHR *buf = (CHR *)malloc(cap); if (!buf) { term_vec_free(&elems); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } size_t off = 0; for (ULO i = 0; i < elems.count; i++) { pl_term *e = deref_term_wam(elems.items[i]); if (!e) { free(buf); term_vec_free(&elems); return cut_none(); } if (e->tag == PL_TERM_VAR) { free(buf); term_vec_free(&elems); return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 2); } if (use_codes) { SLO code = 0; if (e->tag == PL_TERM_INT) { code = e->v.int_value; } else if (e->tag == PL_TERM_BIGINT) { if (!bigint_fits_slo(e->v.bigint, &code)) { free(buf); term_vec_free(&elems); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } } else { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", e, &empty, fn, 2); } if ((code < 0) || (code > 255)) { free(buf); term_vec_free(&elems); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", fn, 2); } buf[off++] = (CHR)(unsigned char)code; } else { if (!atom_is_char(e)) { free(buf); term_vec_free(&elems); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", e, &empty, fn, 2); } const size_t n = strlen(e->v.atom_name); memcpy(buf + off, e->v.atom_name, n); off += n; } } buf[off] = '\0'; term_vec_free(&elems); pl_parsed_number pn = {0}; if (!parse_number_iso_cstr(buf, &pn, vm->rt_ctrl, vm->dbg_dat_ptr)) { free(buf); return throw_syntax_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "illegal_number", fn, 2); } free(buf); if (n->tag == PL_TERM_VAR) { pl_term *num = pn.is_float ? make_float_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pn.fval) : (pn.is_big ? make_bigint_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pn.big) : make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pn.ival)); if (!unify_terms_wam(goal->v.str.args[0], num, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!pn.is_float) { if ((n->tag == PL_TERM_INT) && !pn.is_big && (n->v.int_value == pn.ival)) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (n->tag == PL_TERM_BIGINT) { const int cmp = pn.is_big ? bigint_cmp(n->v.bigint, pn.big) : bigint_cmp_slo(n->v.bigint, pn.ival); if (cmp == 0) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } } } else if ((n->tag == PL_TERM_FLOAT) && (n->v.float_value == pn.fval)) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } return cut_none(); } if (!strcmp(fn, "atom_concat") && (ar == 3) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); pl_term *b = deref_term_wam(goal->v.str.args[1]); pl_term *c = deref_term_wam(goal->v.str.args[2]); if (!a || !b || !c) { return cut_none(); } if ((a->tag != PL_TERM_VAR) && (a->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", a, &empty, "atom_concat", 3); } if ((b->tag != PL_TERM_VAR) && (b->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", b, &empty, "atom_concat", 3); } if ((c->tag != PL_TERM_VAR) && (c->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", c, &empty, "atom_concat", 3); } if ((c->tag == PL_TERM_VAR) && ((a->tag == PL_TERM_VAR) || (b->tag == PL_TERM_VAR))) { // ISO: would enumerate infinitely many solutions. return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom_concat", 3); } if (c->tag == PL_TERM_ATOM) { // Build a goal slice that represents the continuation after atom_concat/3. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const bool release_temp = vm->release_temp; const pl_temp_mark outer_tm = release_temp ? temp_alloc_mark(g_temp_alloc) : (pl_temp_mark){0}; const CHR *s = c->v.atom_name ? c->v.atom_name : ""; const size_t n = strlen(s); for (size_t i = 0; i <= n; i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } CHR *p = (CHR *)malloc(i + 1); CHR *qbuf = (CHR *)malloc((n - i) + 1); if (!p || !qbuf) { free(p); free(qbuf); rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } memcpy(p, s, i); p[i] = '\0'; memcpy(qbuf, s + i, n - i); qbuf[n - i] = '\0'; pl_term *pa = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, p); pl_term *pb = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, qbuf); free(p); free(qbuf); const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], pa, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], pb, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return r; } if (r.cut) { if (r.target == &g_halt_barrier) { if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); // fail: atom_concat/3 handled the continuation itself } // Concatenate A and B to produce C. const CHR *sa = ((pl_term *)a)->v.atom_name ? ((pl_term *)a)->v.atom_name : ""; const CHR *sb = ((pl_term *)b)->v.atom_name ? ((pl_term *)b)->v.atom_name : ""; const size_t na = strlen(sa); const size_t nb = strlen(sb); CHR *buf = (CHR *)malloc(na + nb + 1); if (!buf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } memcpy(buf, sa, na); memcpy(buf + na, sb, nb); buf[na + nb] = '\0'; pl_term *cat = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, buf); free(buf); if (!unify_terms_wam(goal->v.str.args[2], cat, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "sub_atom") && (ar == 5) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", a, &empty, "sub_atom", 5); } pl_term *before_t = deref_term_wam(goal->v.str.args[1]); pl_term *len_t = deref_term_wam(goal->v.str.args[2]); pl_term *after_t = deref_term_wam(goal->v.str.args[3]); pl_term *sub_t = deref_term_wam(goal->v.str.args[4]); if (!before_t || !len_t || !after_t || !sub_t) { return cut_none(); } if ((before_t->tag != PL_TERM_VAR) && (before_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", before_t, &empty, "sub_atom", 5); } if ((len_t->tag != PL_TERM_VAR) && (len_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", len_t, &empty, "sub_atom", 5); } if ((after_t->tag != PL_TERM_VAR) && (after_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", after_t, &empty, "sub_atom", 5); } if ((sub_t->tag != PL_TERM_VAR) && (sub_t->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", sub_t, &empty, "sub_atom", 5); } const bool before_is_var = (before_t->tag == PL_TERM_VAR); const bool len_is_var = (len_t->tag == PL_TERM_VAR); const bool after_is_var = (after_t->tag == PL_TERM_VAR); const SLO before_fixed = before_is_var ? 0 : before_t->v.int_value; const SLO len_fixed = len_is_var ? 0 : len_t->v.int_value; const SLO after_fixed = after_is_var ? 0 : after_t->v.int_value; if (!before_is_var && (before_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", before_t, &empty, "sub_atom", 5); } if (!len_is_var && (len_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", len_t, &empty, "sub_atom", 5); } if (!after_is_var && (after_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", after_t, &empty, "sub_atom", 5); } // Build a goal slice that represents the continuation after sub_atom/5. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); bool stop = false; for (size_t before = 0; before <= n && !stop; before++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } if (!before_is_var && ((SLO)before != before_fixed)) { continue; } const size_t max_len = n - before; for (size_t lenv = 0; lenv <= max_len; lenv++) { if (flowlog_cancelled()) { stop = true; break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { stop = true; break; } if (!len_is_var && ((SLO)lenv != len_fixed)) { continue; } const size_t after = n - before - lenv; if (!after_is_var && ((SLO)after != after_fixed)) { continue; } CHR *subbuf = (CHR *)malloc(lenv + 1); if (!subbuf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } memcpy(subbuf, s + before, lenv); subbuf[lenv] = '\0'; pl_term *suba = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, subbuf); free(subbuf); pl_term *bt = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)before); pl_term *lt = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)lenv); pl_term *at = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)after); const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], bt, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], lt, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[3], at, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[4], suba, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } stop = true; break; } } } return cut_none(); // fail: sub_atom/5 handled the continuation itself } if (!strcmp(fn, "sub_string") && (ar == 5) && goal->v.str.args) { pl_term *a = deref_term_wam(goal->v.str.args[0]); if (!a) { return cut_none(); } if (a->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } if (a->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", a, &empty, "sub_string", 5); } pl_term *before_t = deref_term_wam(goal->v.str.args[1]); pl_term *len_t = deref_term_wam(goal->v.str.args[2]); pl_term *after_t = deref_term_wam(goal->v.str.args[3]); pl_term *sub_t = deref_term_wam(goal->v.str.args[4]); if (!before_t || !len_t || !after_t || !sub_t) { return cut_none(); } if ((before_t->tag != PL_TERM_VAR) && (before_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", before_t, &empty, "sub_string", 5); } if ((len_t->tag != PL_TERM_VAR) && (len_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", len_t, &empty, "sub_string", 5); } if ((after_t->tag != PL_TERM_VAR) && (after_t->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", after_t, &empty, "sub_string", 5); } if ((sub_t->tag != PL_TERM_VAR) && (sub_t->tag != PL_TERM_ATOM)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", sub_t, &empty, "sub_string", 5); } const bool before_is_var = (before_t->tag == PL_TERM_VAR); const bool len_is_var = (len_t->tag == PL_TERM_VAR); const bool after_is_var = (after_t->tag == PL_TERM_VAR); const SLO before_fixed = before_is_var ? 0 : before_t->v.int_value; const SLO len_fixed = len_is_var ? 0 : len_t->v.int_value; const SLO after_fixed = after_is_var ? 0 : after_t->v.int_value; if (!before_is_var && (before_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", before_t, &empty, "sub_string", 5); } if (!len_is_var && (len_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", len_t, &empty, "sub_string", 5); } if (!after_is_var && (after_fixed < 0)) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", after_t, &empty, "sub_string", 5); } // Build a goal slice that represents the continuation after sub_string/5. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const CHR *s = a->v.atom_name ? a->v.atom_name : ""; const size_t n = strlen(s); bool stop = false; for (size_t before = 0; before <= n && !stop; before++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } if (!before_is_var && ((SLO)before != before_fixed)) { continue; } const size_t max_len = n - before; for (size_t lenv = 0; lenv <= max_len; lenv++) { if (flowlog_cancelled()) { stop = true; break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { stop = true; break; } if (!len_is_var && ((SLO)lenv != len_fixed)) { continue; } const size_t after = n - before - lenv; if (!after_is_var && ((SLO)after != after_fixed)) { continue; } CHR *subbuf = (CHR *)malloc(lenv + 1); if (!subbuf) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } memcpy(subbuf, s + before, lenv); subbuf[lenv] = '\0'; pl_term *suba = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, subbuf); free(subbuf); pl_term *bt = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)before); pl_term *lt = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)lenv); pl_term *at = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)after); const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], bt, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], lt, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[3], at, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[4], suba, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } stop = true; break; } } } return cut_none(); // fail: sub_string/5 handled the continuation itself } if (!strcmp(fn, "arg") && (ar == 3) && goal->v.str.args) { pl_term *n = deref_term_wam(goal->v.str.args[0]); if (!n) { return cut_none(); } if (n->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (n->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", n, &empty, "arg", 3); } pl_term *t = deref_term_wam_and_peel_pstr_empty(goal->v.str.args[1]); if (!t) { return cut_none(); } if (t->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (!term_is_compound_like(t)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "compound", t, &empty, "arg", 3); } const SLO idx = n->v.int_value; if (idx < 0) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", n, &empty, "arg", 3); } const ULO arity = term_compound_arity(t); if (idx == 0 || (ULO)idx > arity) { return cut_none(); } pl_term *val = NULL; if (!term_compound_arg_rt(t, idx, &val, vm->rt_ctrl, vm->dbg_dat_ptr) || !val) { return cut_none(); } if (!unify_terms_wam(goal->v.str.args[2], val, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "compare") && (ar == 3) && goal->v.str.args) { pl_term *ord0 = deref_term_wam(goal->v.str.args[0]); if (!ord0) { return cut_none(); } if (ord0->tag != PL_TERM_VAR) { if (ord0->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", ord0, &empty, "compare", 3); } if (strcmp(ord0->v.atom_name, "<") && strcmp(ord0->v.atom_name, ">") && strcmp(ord0->v.atom_name, "=")) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "order", ord0, &empty, "compare", 3); } } const int cr = compare_std_terms_wam(goal->v.str.args[1], goal->v.str.args[2], vm->dbg_dat_ptr); const CHR *sym = (cr < 0) ? "<" : (cr > 0) ? ">" : "="; if (ord0->tag == PL_TERM_ATOM) { if (!strcmp(ord0->v.atom_name, sym)) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } pl_term *ord = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, sym); if (!unify_terms_wam(goal->v.str.args[0], ord, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "findall") && (ar == 3) && goal->v.str.args) { pl_term *templ_in = goal->v.str.args[0]; pl_term *sub_goal_in = deref_term_wam(goal->v.str.args[1]); if (!templ_in || !sub_goal_in) { return cut_none(); } if (sub_goal_in->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if ((sub_goal_in->tag != PL_TERM_ATOM) && (sub_goal_in->tag != PL_TERM_STRUCT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", sub_goal_in, &empty, "findall", 3); } const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; pl_term *templ_now = deref_term_wam(templ_in); const bool templ_ground = templ_now && term_is_syntactic_ground(templ_now, 0); pl_term *list = NULL; pl_term *sub_goals[1] = {sub_goal_in}; ULO inner_sol = 0; const ULO inner_mark = vm->st->trail.count; const ULO inner_scope = vm->st->scope_count; pl_temp_mark inner_tm = {0}; if (vm->release_temp) { inner_tm = temp_alloc_mark(g_temp_alloc); } pl_wamvm_barrier inner_bar = {.prev = NULL, .cp_base = 0}; if (templ_ground) { g_wam_on_solution = NULL; g_wam_on_solution_ctx = NULL; pl_cut_signal inner = solve_goals_wamvm_cb(vm->prog, vm->q, sub_goals, 1, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, false, NULL, &inner_sol, vm->rt_ctrl, vm->dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&vm->st->trail, inner_mark); vm->st->scope_count = inner_scope; if (inner.except) { // IMPORTANT: do not release query-temporary allocations here. // The thrown exception term/environment may be allocated in the current // query temp arena; releasing to `inner_tm` would invalidate it before an // outer catch/3 has a chance to unify the catcher. return inner; } if (vm->release_temp) { temp_alloc_release(g_temp_alloc, inner_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } list = build_repeat_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, templ_now, inner_sol); } else { pl_findall_wam_ctx ctx = {.template = templ_in, .rt_ctrl = vm->rt_ctrl, .dbg_dat_ptr = vm->dbg_dat_ptr}; findall_wam_vec_init(&ctx.results); g_wam_on_solution = findall_wam_on_solution; g_wam_on_solution_ctx = &ctx; pl_cut_signal inner = solve_goals_wamvm_cb(vm->prog, vm->q, sub_goals, 1, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, false, NULL, &inner_sol, vm->rt_ctrl, vm->dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&vm->st->trail, inner_mark); vm->st->scope_count = inner_scope; if (inner.except) { // IMPORTANT: do not release query-temporary allocations here. // The thrown exception term/environment may be allocated in the current // query temp arena; releasing to `inner_tm` would invalidate it before an // outer catch/3 has a chance to unify the catcher. for (ULO i = 0; i < ctx.results.count; i++) { free(ctx.results.items[i].bindings); ctx.results.items[i].bindings = NULL; } findall_wam_vec_free(&ctx.results); if (!g_temp_alloc) { temp_alloc_free_all(&ctx.alloc, vm->rt_ctrl, vm->dbg_dat_ptr); } return inner; } if (vm->release_temp) { temp_alloc_release(g_temp_alloc, inner_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx.alloc, vm->dbg_dat_ptr); } // Wire copied answer scopes into the WAM state for continuation unification. for (ULO ri = 0; ri < ctx.results.count; ri++) { pl_findall_wam_item *it = &ctx.results.items[ri]; if (it->var_count) { pl_wam_cell *cells = wam_state_push_scope(vm->st, it->scope, it->var_count, vm->rt_ctrl, vm->dbg_dat_ptr); if (cells && it->bindings) { for (ULO vi = 0; vi < it->var_count; vi++) { cells[vi].value = it->bindings[vi]; } } } free(it->bindings); it->bindings = NULL; } if (ctx.results.count) { pl_term **elems = (pl_term **)pool_alloc(vm->rt_ctrl, sizeof(pl_term *) * ctx.results.count, vm->dbg_dat_ptr); for (ULO i = 0; i < ctx.results.count; i++) { elems[i] = ctx.results.items[i].term; } list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, elems, ctx.results.count); } else { list = make_nil_rt(vm->dbg_dat_ptr); } findall_wam_vec_free(&ctx.results); if (!g_temp_alloc) { temp_alloc_free_all(&ctx.alloc, vm->rt_ctrl, vm->dbg_dat_ptr); } } if (!unify_terms_wam(goal->v.str.args[2], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if ((!strcmp(fn, "bagof") || !strcmp(fn, "setof")) && (ar == 3) && goal->v.str.args) { const bool is_setof = !strcmp(fn, "setof"); pl_term *templ_in = goal->v.str.args[0]; if (!templ_in) { return cut_none(); } // Build a goal slice that represents the continuation after bagof/setof. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } pl_var_list exist = {0}; var_list_init(&exist); pl_term *goal_core = strip_bagof_existentials_wam(goal->v.str.args[1], &exist, vm->dbg_dat_ptr); if (!goal_core) { var_list_free(&exist); return cut_none(); } pl_term *goal_core_d = deref_term_wam(goal_core); if (!goal_core_d) { var_list_free(&exist); return cut_none(); } if (goal_core_d->tag == PL_TERM_VAR) { var_list_free(&exist); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if ((goal_core_d->tag != PL_TERM_ATOM) && (goal_core_d->tag != PL_TERM_STRUCT)) { pl_env empty = {0}; var_list_free(&exist); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", goal_core_d, &empty, fn, 3); } pl_var_stack stv; pl_var_list goal_vars = {0}; pl_var_list templ_vars = {0}; var_stack_init(&stv); var_list_init(&goal_vars); term_collect_vars_wam_tr(goal_core, &stv, &goal_vars, vm->dbg_dat_ptr, 0); var_stack_free(&stv); var_stack_init(&stv); var_list_init(&templ_vars); term_collect_vars_wam_tr(templ_in, &stv, &templ_vars, vm->dbg_dat_ptr, 0); var_stack_free(&stv); pl_term **free_vars = NULL; ULO free_count = 0; if (goal_vars.count) { free_vars = (pl_term **)malloc(sizeof(pl_term *) * goal_vars.count); if (!free_vars) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } } for (ULO i = 0; i < goal_vars.count; i++) { pl_var_key k = goal_vars.items[i].key; if (var_list_contains_key(&templ_vars, k) || var_list_contains_key(&exist, k)) { continue; } free_vars[free_count++] = goal_vars.items[i].term; } pl_term *outer_key = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, free_vars, free_count); const pl_on_solution_wam_fn saved_on_solution = g_wam_on_solution; void *saved_on_solution_ctx = g_wam_on_solution_ctx; pl_bagof_wam_ctx ctx = {.key = outer_key, .template = templ_in, .rt_ctrl = vm->rt_ctrl, .dbg_dat_ptr = vm->dbg_dat_ptr}; bagof_wam_vec_init(&ctx.results); g_wam_on_solution = bagof_wam_on_solution; g_wam_on_solution_ctx = &ctx; pl_term *sub_goals[1] = {goal_core}; ULO inner_sol = 0; const ULO inner_mark = vm->st->trail.count; const ULO inner_scope = vm->st->scope_count; pl_temp_mark inner_tm = {0}; if (vm->release_temp) { inner_tm = temp_alloc_mark(g_temp_alloc); } pl_wamvm_barrier inner_bar = {.prev = NULL, .cp_base = 0}; pl_cut_signal inner = solve_goals_wamvm_cb(vm->prog, vm->q, sub_goals, 1, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, false, NULL, &inner_sol, vm->rt_ctrl, vm->dbg_dat_ptr, NULL); g_wam_on_solution = saved_on_solution; g_wam_on_solution_ctx = saved_on_solution_ctx; wam_trail_unwind(&vm->st->trail, inner_mark); vm->st->scope_count = inner_scope; pl_cut_signal result = cut_none(); if (inner.except) { // IMPORTANT: do not release query-temporary allocations here. // The thrown exception term/environment may be allocated in the current // query temp arena; releasing to `inner_tm` would invalidate it before an // outer catch/3 has a chance to unify the catcher. if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx.alloc, vm->dbg_dat_ptr); } else { temp_alloc_free_all(&ctx.alloc, vm->rt_ctrl, vm->dbg_dat_ptr); } for (ULO i = 0; i < ctx.results.count; i++) { free(ctx.results.items[i].bindings); ctx.results.items[i].bindings = NULL; } bagof_wam_vec_free(&ctx.results); free(free_vars); var_list_free(&templ_vars); var_list_free(&goal_vars); var_list_free(&exist); return inner; } if (vm->release_temp) { temp_alloc_release(g_temp_alloc, inner_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } if (g_temp_alloc) { temp_alloc_adopt(g_temp_alloc, &ctx.alloc, vm->dbg_dat_ptr); } if (!ctx.results.count) { bagof_wam_vec_free(&ctx.results); if (!g_temp_alloc) { temp_alloc_free_all(&ctx.alloc, vm->rt_ctrl, vm->dbg_dat_ptr); } free(free_vars); var_list_free(&templ_vars); var_list_free(&goal_vars); var_list_free(&exist); return cut_none(); } const ULO scope_mark = vm->st->scope_count; for (ULO ri = 0; ri < ctx.results.count; ri++) { pl_bagof_wam_item *it = &ctx.results.items[ri]; if (it->var_count) { pl_wam_cell *cells = wam_state_push_scope(vm->st, it->scope, it->var_count, vm->rt_ctrl, vm->dbg_dat_ptr); if (cells && it->bindings) { for (ULO vi = 0; vi < it->var_count; vi++) { cells[vi].value = it->bindings[vi]; } } } free(it->bindings); it->bindings = NULL; } pl_solution_group_vec groups = {0}; group_vec_init(&groups); const ULO merge_mark = vm->st->trail.count; for (ULO ri = 0; ri < ctx.results.count; ri++) { pl_bagof_wam_item *it = &ctx.results.items[ri]; if (!it->key || !it->term) { continue; } bool placed = false; for (ULO gi = 0; gi < groups.count; gi++) { pl_solution_group *g = &groups.items[gi]; if (!g->key) { continue; } if (!term_variant_wam(it->key, g->key, vm->dbg_dat_ptr)) { continue; } const ULO key_mark = vm->st->trail.count; if (unify_terms_wam(it->key, g->key, &vm->st->trail, vm->dbg_dat_ptr)) { term_vec_push(&g->templates, vm->dbg_dat_ptr, it->term); placed = true; break; } wam_trail_unwind(&vm->st->trail, key_mark); } if (placed) { continue; } pl_solution_group *g = group_vec_push(&groups, vm->dbg_dat_ptr); g->key = it->key; term_vec_push(&g->templates, vm->dbg_dat_ptr, it->term); } if (groups.count > 1) { const ULO *saved_dbg = g_group_qsort_wam_dbg_dat_ptr; g_group_qsort_wam_dbg_dat_ptr = vm->dbg_dat_ptr; qsort(groups.items, (size_t)groups.count, sizeof(pl_solution_group), qsort_solution_group_cmp_wam); g_group_qsort_wam_dbg_dat_ptr = saved_dbg; } if (is_setof) { for (ULO gi = 0; gi < groups.count; gi++) { pl_solution_group *g = &groups.items[gi]; if (g->templates.count) { const ULO *saved_dbg = g_qsort_wam_dbg_dat_ptr; g_qsort_wam_dbg_dat_ptr = vm->dbg_dat_ptr; qsort(g->templates.items, (size_t)g->templates.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp_wam); g_qsort_wam_dbg_dat_ptr = saved_dbg; } ULO uniq = 0; for (ULO i = 0; i < g->templates.count; i++) { if (!uniq || (compare_std_terms_wam(g->templates.items[i], g->templates.items[uniq - 1], vm->dbg_dat_ptr) != 0)) { g->templates.items[uniq++] = g->templates.items[i]; } } g->templates.count = uniq; } } for (ULO gi = 0; gi < groups.count; gi++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } pl_solution_group *g = &groups.items[gi]; pl_term *bag_list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, g->templates.items, g->templates.count); const ULO out_mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[2], bag_list, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(outer_key, g->key, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner2_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner2_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, out_mark); if (r.except) { result = r; break; } if (r.cut) { if (r.target == &g_halt_barrier) { result = r; break; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } group_vec_free(&groups); bagof_wam_vec_free(&ctx.results); if (!g_temp_alloc) { temp_alloc_free_all(&ctx.alloc, vm->rt_ctrl, vm->dbg_dat_ptr); } wam_trail_unwind(&vm->st->trail, merge_mark); vm->st->scope_count = scope_mark; free(free_vars); var_list_free(&templ_vars); var_list_free(&goal_vars); var_list_free(&exist); return result; // fail: bagof/setof handled the continuation itself } if (!strcmp(fn, "current_predicate") && (ar == 1) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag != PL_TERM_VAR) { if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } pl_term *name_term = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name_term || !arity_term) { return cut_none(); } pl_env empty = {0}; if (name_term->tag != PL_TERM_VAR && name_term->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } if (arity_term->tag != PL_TERM_VAR) { if (arity_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } if (arity_term->v.int_value < 0) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_predicate", 1); } } } // Build a goal slice that represents the continuation after current_predicate/1. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } typedef struct { const CHR *name; ULO arity; } pl_pi; ULO cap = 1; cap += vm->prog->clause_count; cap += vm->prog->fact_count; cap += vm->prog->dyn_pred_count; pl_pi *seen = (pl_pi *)pool_alloc(vm->rt_ctrl, sizeof(*seen) * cap, vm->dbg_dat_ptr); ULO seen_count = 0; if (vm->prog->clauses && vm->prog->clause_count) { for (ULO i = 1; i <= vm->prog->clause_count; i++) { pl_clause *cl = vm->prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { continue; } if (!pred_name) { continue; } bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } if (vm->prog->facts && vm->prog->fact_count) { for (ULO i = 1; i <= vm->prog->fact_count; i++) { const pl_term *h = vm->prog->facts[i]; if (!h) { continue; } const CHR *pred_name = NULL; ULO pred_arity = 0; if (h->tag == PL_TERM_ATOM) { pred_name = h->v.atom_name; pred_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { pred_name = h->v.str.functor; pred_arity = h->v.str.arity; } else { continue; } if (!pred_name) { continue; } bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } if (vm->prog->dyn_preds && vm->prog->dyn_pred_count) { for (ULO i = 1; i <= vm->prog->dyn_pred_count; i++) { const pl_dyn_pred *dp = &vm->prog->dyn_preds[i]; if (!dp || !dp->name) { continue; } const CHR *pred_name = dp->name; const ULO pred_arity = dp->arity; bool dup = false; for (ULO j = 0; j < seen_count; j++) { if ((seen[j].arity == pred_arity) && !strcmp(seen[j].name, pred_name)) { dup = true; break; } } if (dup) { continue; } seen[seen_count++] = (pl_pi){.name = pred_name, .arity = pred_arity}; } } for (ULO i = 0; i < seen_count; i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } pl_term *ind = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "/", 2); ind->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, seen[i].name); ind->v.str.args[1] = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)seen[i].arity); const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], ind, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } return cut_none(); // fail: current_predicate/1 handled the continuation itself } if (!strcmp(fn, "current_rule") && (ar == 1) && goal->v.str.args) { pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "structure"); } if (pi->tag != PL_TERM_STRUCT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "structure", pi, &empty, "current_rule", 1); } if (pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "current_rule", 1); } pl_term *name = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name || !arity_term) { return cut_none(); } pl_env empty = {0}; if (name->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", pi, &empty, "current_rule", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", pi, &empty, "current_rule", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0 || arity_val > 1024) { return cut_none(); } const CHR *pred_name = name->v.atom_name; const ULO pred_arity = (ULO)arity_val; bool dyn = false; const bool defined = builtin_pred_defined(pred_name, pred_arity) || prog_pred_defined(vm->prog, pred_name, pred_arity, &dyn); if (!defined) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "predicate_property") && (ar == 2) && goal->v.str.args) { pl_term *callable = deref_term_wam(goal->v.str.args[0]); if (!callable) { return cut_none(); } if (callable->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_env empty = {0}; if (callable->tag != PL_TERM_ATOM && callable->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", callable, &empty, "predicate_property", 2); } pl_term *base = callable; if (base->tag == PL_TERM_STRUCT && base->v.str.arity == 2 && !strcmp(base->v.str.functor, ":")) { base = deref_term_wam(base->v.str.args[1]); } if (!base) { return cut_none(); } if (base->tag != PL_TERM_ATOM && base->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", base, &empty, "predicate_property", 2); } const CHR *pred_name = (base->tag == PL_TERM_ATOM) ? base->v.atom_name : base->v.str.functor; const ULO pred_arity = (base->tag == PL_TERM_ATOM) ? 0 : base->v.str.arity; bool dyn = false; const bool is_builtin = builtin_pred_defined(pred_name, pred_arity); const bool is_user = prog_pred_defined(vm->prog, pred_name, pred_arity, &dyn); if (!is_builtin && !is_user) { return cut_none(); } pl_term *prop = deref_term_wam(goal->v.str.args[1]); if (!prop) { return cut_none(); } if (prop->tag != PL_TERM_VAR) { const bool ok_atom = prop->tag == PL_TERM_ATOM && (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static") || !strcmp(prop->v.atom_name, "dynamic")); const bool ok_template = prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 1 && !strcmp(prop->v.str.functor, "template"); if (!ok_atom && !ok_template) { return throw_domain_error( frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_property", prop, &empty, "$legacy_predicate_property", 2); } } const bool is_dynamic = is_user && dyn; const bool is_static = is_builtin || (is_user && !dyn); if (prop->tag == PL_TERM_VAR) { // Build a goal slice that represents the continuation after predicate_property/2. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } pl_term *props[8] = {0}; ULO prop_n = 0; if (is_builtin && pred_arity == 0 && (!strcmp(pred_name, "true") || !strcmp(pred_name, "!") || !strcmp(pred_name, "fail") || !strcmp(pred_name, "false"))) { props[prop_n++] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "choice_construct"); } if (is_builtin) { props[prop_n++] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "built_in"); } if (is_static) { props[prop_n++] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "static"); } if (is_dynamic) { props[prop_n++] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "dynamic"); } if (is_builtin) { props[prop_n++] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "iso"); } if (is_builtin && !strcmp(pred_name, "write") && (pred_arity == 1 || pred_arity == 2)) { pl_term *templ = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "write", pred_arity); if (pred_arity == 1) { pl_term *m = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 1); m->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "term"); templ->v.str.args[0] = m; } else { pl_term *m1 = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 1); m1->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); pl_term *m2 = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 1); m2->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "term"); templ->v.str.args[0] = m1; templ->v.str.args[1] = m2; } pl_term *pt = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "template", 1); pt->v.str.args[0] = templ; props[prop_n++] = pt; } for (ULO i = 0; i < prop_n; i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], props[i], &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } return cut_none(); // fail: predicate_property/2 handled the continuation itself } if (prop->tag == PL_TERM_ATOM) { if (!strcmp(prop->v.atom_name, "built_in")) { if (!is_builtin) { return cut_none(); } } else if (!strcmp(prop->v.atom_name, "static")) { if (!is_static) { return cut_none(); } } else if (!strcmp(prop->v.atom_name, "dynamic")) { if (!is_dynamic) { return cut_none(); } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 1 && !strcmp(prop->v.str.functor, "template")) { if (!is_builtin) { return cut_none(); } if (!strcmp(pred_name, "write") && (pred_arity == 1 || pred_arity == 2)) { pl_term *templ = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "write", pred_arity); if (pred_arity == 1) { pl_term *m = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 1); m->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "term"); templ->v.str.args[0] = m; } else { pl_term *m1 = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 1); m1->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); pl_term *m2 = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 1); m2->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "term"); templ->v.str.args[0] = m1; templ->v.str.args[1] = m2; } pl_term *pt = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "template", 1); pt->v.str.args[0] = templ; if (!unify_terms_wam(goal->v.str.args[1], pt, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } return cut_none(); } return cut_none(); } if (!strcmp(fn, "evaluable_property") && (ar == 2) && goal->v.str.args) { pl_term *callable = deref_term_wam(goal->v.str.args[0]); if (!callable) { return cut_none(); } if (callable->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_env empty = {0}; if (callable->tag != PL_TERM_ATOM && callable->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", callable, &empty, "evaluable_property", 2); } pl_term *prop = deref_term_wam(goal->v.str.args[1]); if (!prop) { return cut_none(); } if (prop->tag != PL_TERM_VAR) { const bool ok_atom = prop->tag == PL_TERM_ATOM && (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static") || !strcmp(prop->v.atom_name, "dynamic")); const bool ok_template = prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 2 && !strcmp(prop->v.str.functor, "template"); if (!ok_atom && !ok_template) { return throw_domain_error( frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "evaluable_property", prop, &empty, "$legacy_evaluable_property", 2); } } const CHR *fn_name = (callable->tag == PL_TERM_ATOM) ? callable->v.atom_name : callable->v.str.functor; const ULO fn_arity = (callable->tag == PL_TERM_ATOM) ? 0 : callable->v.str.arity; pl_term *templ_prop = NULL; if (fn_name && fn_arity == 0 && (!strcmp(fn_name, "e") || !strcmp(fn_name, "epsilon") || !strcmp(fn_name, "pi"))) { templ_prop = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, fn_name); templ_prop->v.str.args[1] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "float"); } else if (fn_name && fn_arity == 1) { const CHR *arg_ty = NULL; const CHR *ret_ty = NULL; if (!strcmp(fn_name, "+") || !strcmp(fn_name, "-") || !strcmp(fn_name, "abs") || !strcmp(fn_name, "sign")) { arg_ty = "number"; ret_ty = "number"; } else if (!strcmp(fn_name, "float")) { arg_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "floor") || !strcmp(fn_name, "ceiling") || !strcmp(fn_name, "truncate") || !strcmp(fn_name, "round")) { arg_ty = "float"; ret_ty = "integer"; } else if (!strcmp(fn_name, "float_integer_part") || !strcmp(fn_name, "float_fractional_part")) { arg_ty = "float"; ret_ty = "float"; } else if (!strcmp(fn_name, "sin") || !strcmp(fn_name, "cos") || !strcmp(fn_name, "tan") || !strcmp(fn_name, "asin") || !strcmp(fn_name, "acos") || !strcmp(fn_name, "atan") || !strcmp(fn_name, "sqrt") || !strcmp(fn_name, "log") || !strcmp(fn_name, "exp")) { arg_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "\\")) { arg_ty = "integer"; ret_ty = "integer"; } if (arg_ty && ret_ty) { pl_term *t = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, fn_name, 1); t->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, arg_ty); templ_prop = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = t; templ_prop->v.str.args[1] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ret_ty); } } else if (fn_name && fn_arity == 2) { const CHR *a_ty = NULL; const CHR *b_ty = NULL; const CHR *ret_ty = NULL; if (!strcmp(fn_name, "+") || !strcmp(fn_name, "-") || !strcmp(fn_name, "*") || !strcmp(fn_name, "max") || !strcmp(fn_name, "min")) { a_ty = "number"; b_ty = "number"; ret_ty = "number"; } else if (!strcmp(fn_name, "/")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "//") || !strcmp(fn_name, "div") || !strcmp(fn_name, "mod") || !strcmp(fn_name, "rem") || !strcmp(fn_name, "/\\") || !strcmp(fn_name, "\\/") || !strcmp(fn_name, "xor") || !strcmp(fn_name, "<<") || !strcmp(fn_name, ">>")) { a_ty = "integer"; b_ty = "integer"; ret_ty = "integer"; } else if (!strcmp(fn_name, "**")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } else if (!strcmp(fn_name, "^")) { a_ty = "number"; b_ty = "number"; ret_ty = "integer"; } else if (!strcmp(fn_name, "atan2")) { a_ty = "number"; b_ty = "number"; ret_ty = "float"; } if (a_ty && b_ty && ret_ty) { pl_term *t = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, fn_name, 2); t->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, a_ty); t->v.str.args[1] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, b_ty); templ_prop = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "template", 2); templ_prop->v.str.args[0] = t; templ_prop->v.str.args[1] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ret_ty); } } if (!templ_prop) { return cut_none(); } if (prop->tag == PL_TERM_VAR) { // Build a goal slice that represents the continuation after evaluable_property/2. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const pl_term *props[] = { make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "built_in"), make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "static"), make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "iso"), templ_prop, }; for (ULO i = 0; i < (sizeof(props) / sizeof(props[0])); i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[1], (pl_term *)props[i], &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } return cut_none(); // fail: evaluable_property/2 handled the continuation itself } if (prop->tag == PL_TERM_ATOM) { if (!strcmp(prop->v.atom_name, "built_in") || !strcmp(prop->v.atom_name, "static")) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(prop->v.atom_name, "dynamic")) { return cut_none(); } } if (prop->tag == PL_TERM_STRUCT && prop->v.str.arity == 2 && !strcmp(prop->v.str.functor, "template")) { if (!unify_terms_wam(goal->v.str.args[1], templ_prop, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } return cut_none(); } if (!strcmp(fn, "flowlog_cpuproc_id") && (ar == 1) && goal->v.str.args) { const SLO id = (SLO)get_id_cpuproc_fast(vm->rt_ctrl); pl_term *id_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); if (!unify_terms_wam(goal->v.str.args[0], id_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_n_cpuproc") && (ar == 1) && goal->v.str.args) { const SLO n = (SLO)get_n_cpuproc(); pl_term *n_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, n); if (!unify_terms_wam(goal->v.str.args[0], n_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_in_cpuproc") && (ar == 1) && goal->v.str.args) { pl_term *t_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, am_I_in_the_CPUPROC_module() ? "true" : "false"); if (!unify_terms_wam(goal->v.str.args[0], t_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_taskjob_id") && (ar == 1) && goal->v.str.args) { const SLO id = (SLO)get_id_taskjob_fast(vm->rt_ctrl); pl_term *id_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); if (!unify_terms_wam(goal->v.str.args[0], id_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_n_taskjob") && (ar == 1) && goal->v.str.args) { const SLO n = (SLO)get_n_taskjob(); pl_term *n_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, n); if (!unify_terms_wam(goal->v.str.args[0], n_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_last_tc_cp_mask") && (ar == 1) && goal->v.str.args) { pl_term *m_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)g_last_tc_cp_mask); if (!unify_terms_wam(goal->v.str.args[0], m_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_last_tc_cp_count") && (ar == 1) && goal->v.str.args) { const unsigned long long m = (unsigned long long)g_last_tc_cp_mask; const SLO n = (SLO)__builtin_popcountll(m); pl_term *n_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, n); if (!unify_terms_wam(goal->v.str.args[0], n_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_last_tc_worker_count") && (ar == 1) && goal->v.str.args) { pl_term *n_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)g_last_tc_worker_count); if (!unify_terms_wam(goal->v.str.args[0], n_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_last_tc_start_ok") && (ar == 1) && goal->v.str.args) { pl_term *n_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)g_last_tc_start_ok); if (!unify_terms_wam(goal->v.str.args[0], n_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_last_tc_start_error_code") && (ar == 1) && goal->v.str.args) { pl_term *n_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)g_last_tc_start_err_code); if (!unify_terms_wam(goal->v.str.args[0], n_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_last_tc_start_error_text") && (ar == 1) && goal->v.str.args) { pl_term *t_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, g_last_tc_start_err_text); if (!unify_terms_wam(goal->v.str.args[0], t_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_db_epochs") && (ar == 2) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } const unsigned long clause_epoch = atomic_load_explicit(&vm->prog->clause_epoch, memory_order_acquire); const unsigned long index_epoch = atomic_load_explicit(&vm->prog->index_epoch, memory_order_acquire); pl_term *cl_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)clause_epoch); pl_term *ix_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)index_epoch); if (!unify_terms_wam(goal->v.str.args[0], cl_term, &vm->st->trail, vm->dbg_dat_ptr) || !unify_terms_wam(goal->v.str.args[1], ix_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_and_safe") && (ar == 2) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator"); } if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "flowlog_and_safe", 2); } pl_term *name = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator"); } pl_env empty = {0}; if (name->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", name, &empty, "flowlog_and_safe", 2); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", arity_term, &empty, "flowlog_and_safe", 2); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "flowlog_and_safe", 2); } prog_par_and_safety_ensure(vm->prog, vm->rt_ctrl, vm->dbg_dat_ptr); bool safe = false; if (vm->prog->pred_index) { pl_pred_index_entry *e = pred_index_find_pred(vm->prog->pred_index, name->v.atom_name, (ULO)arity_val); safe = e && e->and_safe; } pl_term *safe_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, safe ? "true" : "false"); if (!unify_terms_wam(goal->v.str.args[1], safe_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flowlog_and_safe_goal") && (ar == 2) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *g0 = deref_term_wam(goal->v.str.args[0]); if (!g0) { return cut_none(); } if (g0->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable"); } if (g0->tag != PL_TERM_ATOM && g0->tag != PL_TERM_STRUCT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", g0, &empty, "flowlog_and_safe_goal", 2); } const bool safe = par_and_goal_is_safe_test_wam(vm->prog, g0, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *safe_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, safe ? "true" : "false"); if (!unify_terms_wam(goal->v.str.args[1], safe_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "listing") && (ar == 1) && goal->v.str.args) { pl_term *spec0 = deref_term_wam(goal->v.str.args[0]); if (!spec0) { return cut_none(); } if (spec0->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "listing", 1); } pl_term *spec = spec0; if (spec->tag == PL_TERM_STRUCT && spec->v.str.arity == 2 && !strcmp(spec->v.str.functor, ":")) { spec = deref_term_wam(spec->v.str.args[1]); if (!spec) { return cut_none(); } } const CHR *want_name = NULL; bool any_arity = false; ULO want_arity = 0; if (spec->tag == PL_TERM_ATOM) { want_name = spec->v.atom_name; any_arity = true; } else if (spec->tag == PL_TERM_STRUCT && spec->v.str.arity == 2 && !strcmp(spec->v.str.functor, "/")) { pl_term *name_term = deref_term_wam(spec->v.str.args[0]); pl_term *arity_term = deref_term_wam(spec->v.str.args[1]); if (!name_term || !arity_term) { return cut_none(); } if (name_term->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "listing", 1); } pl_env empty = {0}; if (name_term->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", spec0, &empty, "listing", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", spec0, &empty, "listing", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", spec0, &empty, "listing", 1); } want_name = name_term->v.atom_name; want_arity = (ULO)arity_val; any_arity = false; } else if (spec->tag == PL_TERM_STRUCT || spec->tag == PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", spec0, &empty, "listing", 1); } else { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", spec0, &empty, "listing", 1); } if (!want_name) { return cut_none(); } streams_init(vm->dbg_dat_ptr); const SLO id = g_streams.current_output; pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { return cut_none(); } pl_env empty = {0}; if (!s->writable) { pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "listing", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "listing", 1); } const pl_clause **snap = NULL; ULO snap_count = 0; if (vm->prog && vm->prog->clauses && vm->prog->clause_count) { prog_db_rlock(vm->prog); snap = (const pl_clause **)pool_alloc(vm->rt_ctrl, sizeof(*snap) * vm->prog->clause_count, vm->dbg_dat_ptr); for (ULO i = 1; i <= vm->prog->clause_count; i++) { const pl_clause *cl = vm->prog->clauses[i]; if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h->tag == PL_TERM_ATOM) { h_name = h->v.atom_name; h_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { h_name = h->v.str.functor; h_arity = h->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, want_name) || (!any_arity && (h_arity != want_arity))) { continue; } snap[snap_count++] = cl; } prog_db_runlock(vm->prog); } for (ULO i = 0; i < snap_count; i++) { if (flowlog_cancelled()) { break; } const pl_clause *cl = snap[i]; if (!cl || !cl->head) { continue; } pl_temp_mark m = {0}; const bool release_temp = (g_temp_alloc != NULL); if (release_temp) { m = temp_alloc_mark(g_temp_alloc); } pl_term *t = cl->head; if (cl->body_count && cl->body) { pl_term **body_goals = (pl_term **)pool_alloc(vm->rt_ctrl, sizeof(pl_term *) * cl->body_count, vm->dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = cl->body[bi + 1]; } pl_term *body_term = build_conjunction_rt(vm->rt_ctrl, vm->dbg_dat_ptr, body_goals, cl->body_count); pl_term *rule = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ":-", 2); rule->v.str.args[0] = cl->head; rule->v.str.args[1] = body_term; t = rule; } pl_sbuf sb; sbuf_init(&sb, vm->rt_ctrl, vm->dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false}; write_term_to_sbuf(vm->prog ? vm->prog->op_overrides : NULL, t, cl->env, &wopts, &sb, vm->dbg_dat_ptr); sbuf_append_char(&sb, '.'); sbuf_append_char(&sb, '\n'); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); if (release_temp) { temp_alloc_release(g_temp_alloc, m, vm->rt_ctrl, vm->dbg_dat_ptr); } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "current_op") && (ar == 3) && goal->v.str.args) { // Build a goal slice that represents the continuation after current_op/3. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const pl_op_overrides *ops = vm->prog ? vm->prog->op_overrides : NULL; for (ULO i = 0; i < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const pl_op_decl *base = &PL_OPS[i]; const pl_op_decl *op = base; const pl_op_decl *ov = op_override_find(ops, base->name, base->fix); if (ov) { if (!ov->prec) { continue; // disabled } op = ov; } const CHR *spec = NULL; switch (op->fix) { case PL_OP_INFIX_XFX: spec = "xfx"; break; case PL_OP_INFIX_XFY: spec = "xfy"; break; case PL_OP_INFIX_YFX: spec = "yfx"; break; case PL_OP_PREFIX_FX: spec = "fx"; break; case PL_OP_PREFIX_FY: spec = "fy"; break; case PL_OP_POSTFIX_XF: spec = "xf"; break; case PL_OP_POSTFIX_YF: spec = "yf"; break; } if (!spec) { continue; } pl_term *prec_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)op->prec); pl_term *spec_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, spec); pl_term *name_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, op->name); const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], prec_term, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], spec_term, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], name_term, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } // Enumerate operators introduced via op/3 that are not present in the base table. if (ops) { for (ULO i = 0; i < ops->count; i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const pl_op_decl *op = &ops->items[i]; if (!op->prec) { continue; } bool in_base = false; for (ULO j = 0; j < (sizeof(PL_OPS) / sizeof(PL_OPS[0])); j++) { const pl_op_decl *base = &PL_OPS[j]; if (base->fix == op->fix && !strcmp(base->name, op->name)) { in_base = true; break; } } if (in_base) { continue; } const CHR *spec = NULL; switch (op->fix) { case PL_OP_INFIX_XFX: spec = "xfx"; break; case PL_OP_INFIX_XFY: spec = "xfy"; break; case PL_OP_INFIX_YFX: spec = "yfx"; break; case PL_OP_PREFIX_FX: spec = "fx"; break; case PL_OP_PREFIX_FY: spec = "fy"; break; case PL_OP_POSTFIX_XF: spec = "xf"; break; case PL_OP_POSTFIX_YF: spec = "yf"; break; } if (!spec) { continue; } pl_term *prec_term = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)op->prec); pl_term *spec_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, spec); pl_term *name_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, op->name); const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], prec_term, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], spec_term, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], name_term, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } } return cut_none(); // fail: current_op/3 handled the continuation itself } if (!strcmp(fn, "op") && (ar == 3) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *prec_term = deref_term_wam(goal->v.str.args[0]); if (!prec_term) { return cut_none(); } if (prec_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer"); } if (prec_term->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", prec_term, &empty, "op", 3); } const SLO prec_val = prec_term->v.int_value; if (prec_val < 0 || prec_val > 1200) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "operator_priority", prec_term, &empty, "op", 3); } pl_term *spec_term = deref_term_wam(goal->v.str.args[1]); if (!spec_term) { return cut_none(); } if (spec_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } if (spec_term->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", spec_term, &empty, "op", 3); } pl_op_fix fix = PL_OP_INFIX_XFX; if (!strcmp(spec_term->v.atom_name, "xfx")) { fix = PL_OP_INFIX_XFX; } else if (!strcmp(spec_term->v.atom_name, "xfy")) { fix = PL_OP_INFIX_XFY; } else if (!strcmp(spec_term->v.atom_name, "yfx")) { fix = PL_OP_INFIX_YFX; } else if (!strcmp(spec_term->v.atom_name, "fx")) { fix = PL_OP_PREFIX_FX; } else if (!strcmp(spec_term->v.atom_name, "fy")) { fix = PL_OP_PREFIX_FY; } else if (!strcmp(spec_term->v.atom_name, "xf")) { fix = PL_OP_POSTFIX_XF; } else if (!strcmp(spec_term->v.atom_name, "yf")) { fix = PL_OP_POSTFIX_YF; } else { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "operator_specifier", spec_term, &empty, "op", 3); } pl_term *ops_term = deref_term_wam(goal->v.str.args[2]); if (!ops_term) { return cut_none(); } if (ops_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list"); } // Match Trealla behaviour: treat [] and {} as operator names (not a list), so // accept list syntax only for non-empty '.'/2 lists. if (ops_term->tag == PL_TERM_ATOM) { const CHR *name = ops_term->v.atom_name; if (!strcmp(name, ",")) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "operator", ops_term, &empty, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "create", "operator", ops_term, &empty, "op", 3); } (void)op_override_set(vm->prog, name, fix, (int)prec_val, vm->rt_ctrl, vm->dbg_dat_ptr); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!term_is_list_pair(ops_term)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", ops_term, &empty, "op", 3); } pl_term *cur = ops_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (term_is_nil(cur)) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (term_is_list_pair(cur)) { pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } if (h->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", h, &empty, "op", 3); } const CHR *name = h->v.atom_name; if (!strcmp(name, ",")) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "operator", h, &empty, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "create", "operator", h, &empty, "op", 3); } (void)op_override_set(vm->prog, name, fix, (int)prec_val, vm->rt_ctrl, vm->dbg_dat_ptr); cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "op", 3); } continue; } // Trealla accepts '.'/2 lists whose tail is an atom and treats that tail // as an additional operator name (e.g. op(500,xfx,[a|b])). if (cur->tag == PL_TERM_ATOM) { const CHR *name = cur->v.atom_name; if (!strcmp(name, ",")) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "operator", cur, &empty, "op", 3); } if (!strcmp(name, "[]") || !strcmp(name, "{}") || !strcmp(name, "|")) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "create", "operator", cur, &empty, "op", 3); } (void)op_override_set(vm->prog, name, fix, (int)prec_val, vm->rt_ctrl, vm->dbg_dat_ptr); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Tail is a variable: insufficiently instantiated; otherwise ignore. if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", ops_term, &empty, "op", 3); } if (!strcmp(fn, "char_conversion") && (ar == 2) && goal->v.str.args) { pl_term *in = deref_term_wam(goal->v.str.args[0]); pl_term *outc = deref_term_wam(goal->v.str.args[1]); if (!in || !outc) { return cut_none(); } if (in->tag == PL_TERM_VAR || outc->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character"); } unsigned char in_code = 0; unsigned char out_code = 0; pl_env empty = {0}; if (in->tag == PL_TERM_ATOM) { if (!in->v.atom_name || strlen(in->v.atom_name) != 1) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", in, &empty, "char_conversion", 2); } in_code = (unsigned char)in->v.atom_name[0]; } else if (in->tag == PL_TERM_INT) { if (in->v.int_value <= 0 || in->v.int_value > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", in, &empty, "char_conversion", 2); } in_code = (unsigned char)in->v.int_value; } else { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", in, &empty, "char_conversion", 2); } if (outc->tag == PL_TERM_ATOM) { if (!outc->v.atom_name || strlen(outc->v.atom_name) != 1) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", outc, &empty, "char_conversion", 2); } out_code = (unsigned char)outc->v.atom_name[0]; } else if (outc->tag == PL_TERM_INT) { if (outc->v.int_value <= 0 || outc->v.int_value > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", outc, &empty, "char_conversion", 2); } out_code = (unsigned char)outc->v.int_value; } else { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", outc, &empty, "char_conversion", 2); } if (vm->prog) { vm->prog->char_conv_table[in_code] = out_code; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "current_char_conversion") && (ar == 2) && goal->v.str.args) { pl_term *in = deref_term_wam(goal->v.str.args[0]); pl_term *outc = deref_term_wam(goal->v.str.args[1]); if (!in || !outc) { return cut_none(); } const bool in_is_var = (in->tag == PL_TERM_VAR); const bool out_is_var = (outc->tag == PL_TERM_VAR); unsigned char in_code = 0; unsigned char out_code = 0; pl_env empty = {0}; if (!in_is_var) { if (in->tag == PL_TERM_ATOM) { if (!in->v.atom_name || strlen(in->v.atom_name) != 1) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", in, &empty, "current_char_conversion", 2); } in_code = (unsigned char)in->v.atom_name[0]; } else if (in->tag == PL_TERM_INT) { if (in->v.int_value <= 0 || in->v.int_value > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", in, &empty, "current_char_conversion", 2); } in_code = (unsigned char)in->v.int_value; } else { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", in, &empty, "current_char_conversion", 2); } } if (!out_is_var) { if (outc->tag == PL_TERM_ATOM) { if (!outc->v.atom_name || strlen(outc->v.atom_name) != 1) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", outc, &empty, "current_char_conversion", 2); } out_code = (unsigned char)outc->v.atom_name[0]; } else if (outc->tag == PL_TERM_INT) { if (outc->v.int_value <= 0 || outc->v.int_value > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", outc, &empty, "current_char_conversion", 2); } out_code = (unsigned char)outc->v.int_value; } else { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", outc, &empty, "current_char_conversion", 2); } } const unsigned char *tbl = vm->prog ? vm->prog->char_conv_table : NULL; if (!in_is_var) { const unsigned char mapped = tbl ? tbl[in_code] : in_code; if (!out_is_var) { if (mapped != out_code) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } CHR tmp[2] = {(CHR)mapped, '\0'}; pl_term *mapped_atom = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, tmp); if (!unify_terms_wam(goal->v.str.args[1], mapped_atom, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Enumerate all conversions. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } for (unsigned int c = 1; c <= 255; c++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const unsigned char mapped = tbl ? tbl[c] : (unsigned char)c; if (!out_is_var && (mapped != out_code)) { continue; } CHR in_tmp[2] = {(CHR)c, '\0'}; CHR out_tmp[2] = {(CHR)mapped, '\0'}; pl_term *in_atom = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, in_tmp); pl_term *out_atom = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, out_tmp); const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], in_atom, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], out_atom, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } return cut_none(); // fail: current_char_conversion/2 handled the continuation itself } if (!strcmp(fn, "dynamic") && (ar == 1) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *pis = deref_term_wam(goal->v.str.args[0]); if (!pis) { return cut_none(); } if (pis->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "dynamic", 1); } if (term_is_nil(pis)) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } const bool list_mode = term_is_list_pair(pis); pl_term *cur = pis; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { pl_term *pi = NULL; if (list_mode) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", pis, &empty, "dynamic", 1); } pi = deref_term_wam(cur->v.str.args[0]); cur = deref_term_wam(cur->v.str.args[1]); if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "dynamic", 1); } } else { pi = deref_term_wam(cur); cur = NULL; } if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "dynamic", 1); } if (pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "dynamic", 1); } pl_term *name_term = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name_term || !arity_term) { return cut_none(); } if (name_term->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "dynamic", 1); } pl_env empty = {0}; if (name_term->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", name_term, &empty, "dynamic", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", arity_term, &empty, "dynamic", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "dynamic", 1); } if (arity_val > 1024) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "max_arity", "dynamic", 1); } const CHR *pred_name = name_term->v.atom_name; const ULO pred_arity = (ULO)arity_val; if (builtin_pred_defined(pred_name, pred_arity)) { pl_term *pi_term = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi_term, &empty, "dynamic", 1); } prog_dyn_pred_add(vm->prog, pred_name, pred_arity, vm->rt_ctrl, vm->dbg_dat_ptr); if (!list_mode) { break; } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "current_input") && (ar == 1) && goal->v.str.args) { streams_init(vm->dbg_dat_ptr); pl_term *st_term = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, g_streams.current_input); if (!unify_terms_wam(goal->v.str.args[0], st_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "current_output") && (ar == 1) && goal->v.str.args) { streams_init(vm->dbg_dat_ptr); pl_term *st_term = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, g_streams.current_output); if (!unify_terms_wam(goal->v.str.args[0], st_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "current_error") && (ar == 1) && goal->v.str.args) { streams_init(vm->dbg_dat_ptr); pl_term *st_term = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, 2); if (!unify_terms_wam(goal->v.str.args[0], st_term, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "set_input") && (ar == 1) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_input", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_input", 1); } if (!s->readable) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "set_input", 1); } streams_init(vm->dbg_dat_ptr); g_streams.current_input = id; frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "set_output") && (ar == 1) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_output", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_output", 1); } if (!s->writable) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "set_output", 1); } streams_init(vm->dbg_dat_ptr); g_streams.current_output = id; frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "set_error") && (ar == 1) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_error", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_error", 1); } if (!s->writable) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "set_error", 1); } // Trealla's set_error/1 currently validates but does not affect current_error/1. frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "open") && ((ar == 3) || (ar == 4)) && goal->v.str.args) { pl_env empty = {0}; pl_term *file = deref_term_wam(goal->v.str.args[0]); pl_term *mode = deref_term_wam(goal->v.str.args[1]); if (!file || !mode) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink", file, &empty, "open", 4); } if (mode->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } if (mode->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", mode, &empty, "open", 4); } streams_init(vm->dbg_dat_ptr); bool binary_stream = false; // default: text_stream bool repositionable = true; unsigned char eof_action = PL_EOF_ACTION_EOF_CODE; bool bom_specified = false; bool use_bom = false; const CHR *alias_name = NULL; if (ar == 4) { pl_term *opts = deref_term_wam(goal->v.str.args[3]); if (!opts) { return cut_none(); } if (opts->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list"); } pl_term *cur = opts; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (!term_is_list_pair(cur)) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", cur, &empty, "open", 4); } pl_term *opt = deref_term_wam(cur->v.str.args[0]); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (opt->tag != PL_TERM_STRUCT) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(opt->v.str.functor, "type") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(v->v.atom_name, "binary")) { binary_stream = true; } else if (!strcmp(v->v.atom_name, "text")) { binary_stream = false; } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "reposition") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(v->v.atom_name, "true")) { repositionable = true; } else if (!strcmp(v->v.atom_name, "false")) { repositionable = false; } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "eof_action") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(v->v.atom_name, "eof_code")) { eof_action = PL_EOF_ACTION_EOF_CODE; } else if (!strcmp(v->v.atom_name, "error")) { eof_action = PL_EOF_ACTION_ERROR; } else if (!strcmp(v->v.atom_name, "reset")) { eof_action = PL_EOF_ACTION_RESET; } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "bom") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } if (!strcmp(v->v.atom_name, "true")) { bom_specified = true; use_bom = true; } else if (!strcmp(v->v.atom_name, "false")) { bom_specified = true; use_bom = false; } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } } else if (!strcmp(opt->v.str.functor, "alias") && opt->v.str.arity == 1) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } alias_name = v->v.atom_name; } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option", opt, &empty, "open", 4); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "open", 4); } } } const CHR *m = mode->v.atom_name ? mode->v.atom_name : ""; bool readable = false; bool writable = false; if (!strcmp(m, "read")) { readable = true; } else if (!strcmp(m, "write") || !strcmp(m, "append")) { writable = true; } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "io_mode", mode, &empty, "open", 4); } char smode[8]; smode[0] = '\0'; if (!strcmp(m, "read")) { (void)snprintf(smode, sizeof(smode), "%s", binary_stream ? "rb" : "r"); } else if (!strcmp(m, "write")) { (void)snprintf(smode, sizeof(smode), "%s", binary_stream ? "wb" : "w"); } else if (!strcmp(m, "append")) { (void)snprintf(smode, sizeof(smode), "%s", binary_stream ? "ab" : "a"); } FILE *fp = fopen(file->v.atom_name ? file->v.atom_name : "", smode); if (!fp) { if (!strcmp(m, "read")) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink", file, &empty, "open", 4); } return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "open", "source_sink", file, &empty, "open", 4); } const SLO id = stream_alloc_id(vm->dbg_dat_ptr); if (id < 0) { (void)fclose(fp); return cut_none(); } g_streams.items[id] = (pl_stream){.open = true, .readable = readable, .writable = writable, .binary = binary_stream, .repositionable = repositionable, .eof_action = eof_action, .bom = false, .encoding = binary_stream ? NULL : strdup("UTF-8"), .fp = fp, .alias = alias_name ? strdup(alias_name) : NULL, .file_name = strdup(file->v.atom_name ? file->v.atom_name : ""), .line_count = 1, .line_pos = 1, .mode = strdup(mode->v.atom_name ? mode->v.atom_name : "")}; if (!binary_stream) { bool is_regular = false; { struct stat stbuf; const int fd = fileno(fp); if (fd >= 0 && (fstat(fd, &stbuf) == 0) && S_ISREG(stbuf.st_mode)) { is_regular = true; } } if (!is_regular && !bom_specified) { bom_specified = true; use_bom = false; } pl_stream *s = &g_streams.items[id]; if (readable && (!bom_specified || use_bom)) { const int b0 = fgetc(fp); const int b1 = fgetc(fp); const int b2 = fgetc(fp); if (b0 == 0xEF && b1 == 0xBB && b2 == 0xBF) { s->bom = true; } else { if (b2 != EOF) { stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)b2); } if (b1 != EOF) { stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)b1); } if (b0 != EOF) { stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)b0); } } if (feof(fp)) { clearerr(fp); } } else if (!strcmp(m, "write") && use_bom) { const unsigned char bom_bytes[3] = {0xEF, 0xBB, 0xBF}; (void)fwrite(bom_bytes, 1, sizeof(bom_bytes), fp); s->bom = true; } } pl_term *st_out = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); if (!unify_terms_wam(goal->v.str.args[2], st_out, &vm->st->trail, vm->dbg_dat_ptr)) { (void)fclose(fp); stream_free_pushback(&g_streams.items[id]); stream_free_meta(&g_streams.items[id]); g_streams.items[id] = (pl_stream){0}; return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "close") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "close", ar); } if (ar == 2) { pl_term *opts = deref_term_wam(goal->v.str.args[1]); if (!opts) { return cut_none(); } if (opts->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list"); } pl_term *cur = opts; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "close_option"); } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", cur, &empty, "close", 2); } pl_term *opt = deref_term_wam(cur->v.str.args[0]); if (!opt) { return cut_none(); } if (opt->tag != PL_TERM_STRUCT || opt->v.str.arity != 1 || strcmp(opt->v.str.functor, "force")) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "close_option", opt, &empty, "close", 2); } pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag != PL_TERM_ATOM || strcmp(v->v.atom_name, "true")) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "close_option", opt, &empty, "close", 2); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "close", 2); } } } streams_init(vm->dbg_dat_ptr); if (id >= 0 && id <= 2) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { pl_env empty = {0}; return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "close", ar); } if (s->fp) { (void)fclose(s->fp); } stream_free_pushback(s); stream_free_meta(s); g_streams.items[id] = (pl_stream){0}; if (g_streams.current_input == id) { g_streams.current_input = 0; } if (g_streams.current_output == id) { g_streams.current_output = 1; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "set_stream") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_stream", 2); } streams_init(vm->dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_stream", 2); } pl_term *opt = deref_term_wam(goal->v.str.args[1]); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_property"); } if (opt->tag != PL_TERM_STRUCT) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_property", opt, &empty, "set_stream", 2); } if (!strcmp(opt->v.str.functor, "alias") && (opt->v.str.arity >= 1)) { pl_term *alias_term = deref_term_wam(opt->v.str.args[0]); if (!alias_term) { return cut_none(); } if (alias_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_option"); } if (alias_term->tag != PL_TERM_ATOM) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_property", opt, &empty, "set_stream", 2); } // Clear alias from any other stream, then set it on this stream. for (size_t i = 0; i < g_streams.cap; i++) { pl_stream *s2 = &g_streams.items[i]; if (!s2->open || !s2->alias) { continue; } if (!strcmp(s2->alias, alias_term->v.atom_name)) { free(s2->alias); s2->alias = NULL; } } free(s->alias); s->alias = strdup(alias_term->v.atom_name); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Known but immutable stream properties: fail without error. if ((opt->v.str.arity == 1) && (!strcmp(opt->v.str.functor, "type") || !strcmp(opt->v.str.functor, "mode") || !strcmp(opt->v.str.functor, "file_name") || !strcmp(opt->v.str.functor, "file_no") || !strcmp(opt->v.str.functor, "line_count") || !strcmp(opt->v.str.functor, "position") || !strcmp(opt->v.str.functor, "reposition") || !strcmp(opt->v.str.functor, "end_of_stream") || !strcmp(opt->v.str.functor, "eof_action") || !strcmp(opt->v.str.functor, "bom") || !strcmp(opt->v.str.functor, "encoding") || !strcmp(opt->v.str.functor, "newline"))) { return cut_none(); } return cut_none(); } if (!strcmp(fn, "set_stream_position") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); pl_term *pos_term = deref_term_wam(goal->v.str.args[1]); if (!st_term || !pos_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_stream_position", 2); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "set_stream_position", 2); } const bool repositionable = s->repositionable; if (!repositionable) { if (pos_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "reposition,stream"); } return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "reposition", "stream", pos_term, &empty, "set_stream_position", 2); } if (pos_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_position"); } if (pos_term->tag != PL_TERM_INT) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream_position", pos_term, &empty, "set_stream_position", 2); } const SLO pos = pos_term->v.int_value; if (pos < 0) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "position", pos_term, &empty, "set_stream_position", 2); } if (!stream_set_position(s, (long)pos)) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "reposition", "stream", pos_term, &empty, "set_stream_position", 2); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "stream_property") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); pl_term *st_term = deref_term_wam(goal->v.str.args[0]); pl_term *prop_term = deref_term_wam(goal->v.str.args[1]); if (!st_term || !prop_term) { return cut_none(); } // Build a goal slice that represents the continuation after stream_property/2. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const bool prop_is_var = (prop_term->tag == PL_TERM_VAR); const bool stream_is_var = (st_term->tag == PL_TERM_VAR); SLO fixed_id = -1; if (!stream_is_var) { if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &fixed_id)) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "stream_property", 2); } pl_stream *s = NULL; if (!stream_lookup(fixed_id, &s, vm->dbg_dat_ptr)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "stream_property", 2); } // Trealla: aliases work for property lookup but do not enumerate. if ((st_term->tag == PL_TERM_ATOM) && prop_is_var) { return cut_none(); } } const size_t start = stream_is_var ? 0 : (size_t)fixed_id; const size_t end = stream_is_var ? g_streams.cap : ((size_t)fixed_id + 1); for (size_t i = start; i < end; i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const SLO id = (SLO)i; pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { continue; } pl_term *stream_val = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); pl_term *props[16]; ULO prop_n = 0; if (s->alias) { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "alias", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, s->alias); props[prop_n++] = p; } if (s->file_name) { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "file_name", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, s->file_name); props[prop_n++] = p; } { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "file_no", 1); p->v.str.args[0] = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)fileno(s->fp)); props[prop_n++] = p; } if (s->mode) { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "mode", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, s->mode); props[prop_n++] = p; } { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "type", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, s->binary ? "binary" : "text"); props[prop_n++] = p; } { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "line_count", 1); p->v.str.args[0] = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)(s->line_count ? s->line_count : 1)); props[prop_n++] = p; } { SLO pos = 0; if (id == 1 || id == 2) { pos = -1; } else if (id >= 4) { const long p = ftell(s->fp); pos = (p >= 0) ? (SLO)p : -1; if (pos >= 0 && s->readable && s->pushback_count) { pos -= (SLO)s->pushback_count; if (pos < 0) { pos = 0; } } } pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "position", 1); p->v.str.args[0] = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pos); props[prop_n++] = p; } { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "reposition", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, s->repositionable ? "true" : "false"); props[prop_n++] = p; } { const CHR *eos = "not"; if (!s->readable) { eos = (id <= 2) ? "not" : "at"; } else if (s->pushback_count) { eos = "not"; } else if (s->eof_action == PL_EOF_ACTION_RESET) { eos = "not"; } else if (s->eos_past) { eos = "past"; } else if ((id >= 4) && stream_regular_file_at_end(s)) { eos = "at"; } else { eos = "not"; } pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "end_of_stream", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, eos); props[prop_n++] = p; } { const CHR *ea = "eof_code"; if (s->eof_action == PL_EOF_ACTION_ERROR) { ea = "error"; } else if (s->eof_action == PL_EOF_ACTION_RESET) { ea = "reset"; } pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "eof_action", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ea); props[prop_n++] = p; } if (!s->binary) { { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "bom", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, s->bom ? "true" : "false"); props[prop_n++] = p; } { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "encoding", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, s->encoding ? s->encoding : "UTF-8"); props[prop_n++] = p; } } if (s->readable) { props[prop_n++] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "input"); } if (s->writable) { props[prop_n++] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "output"); } { pl_term *p = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "newline", 1); p->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "posix"); props[prop_n++] = p; } for (ULO pi = 0; pi < prop_n; pi++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); if ((stream_is_var ? unify_terms_wam(goal->v.str.args[0], stream_val, &vm->st->trail, vm->dbg_dat_ptr) : true) && unify_terms_wam(goal->v.str.args[1], props[pi], &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { return r; } if (r.cut) { if (r.target == &g_halt_barrier) { return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } } return cut_none(); // fail: stream_property/2 handled the continuation itself } if (!strcmp(fn, "nl") && (ar == 1) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "nl", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "nl", 1); } if (!s->writable) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "nl", 1); } stream_write_char(s, id, '\n'); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "flush_output") && (ar == 1) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "flush_output", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "flush_output", 1); } if (!s->writable) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "flush_output", 1); } if (flowlog_capture_user_output_stream(id)) { stream_drain_user_output_capture_if_enabled(s, id, vm->rt_ctrl, vm->dbg_dat_ptr); } else { (void)fflush(s->fp); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "at_end_of_stream") && (ar == 1) && goal->v.str.args) { pl_env empty = {0}; pl_term *st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } SLO id = -1; if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "at_end_of_stream", 1); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "at_end_of_stream", 1); } if (!s->readable) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "at_end_of_stream", 1); } if (s->pushback_count) { return cut_none(); } const int c = fgetc(s->fp); if (c == EOF) { frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)c); return cut_none(); } if (!strcmp(fn, "tab") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *n_term = deref_term_wam(goal->v.str.args[0]); if (ar == 2) { if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return cut_none(); } n_term = deref_term_wam(goal->v.str.args[1]); } if (!n_term || n_term->tag != PL_TERM_INT) { return cut_none(); } const SLO n = n_term->v.int_value; if (n < 0 || n > 65535) { return cut_none(); } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr) || !s->writable) { return cut_none(); } for (SLO i = 0; i < n; i++) { stream_write_char(s, id, ' '); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "get_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "get_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "get_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag != PL_TERM_VAR && code_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", code_term, &empty, "get_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "get_code", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "get_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "get_code", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (code == -1); pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, code); if (!unify_terms_wam(code_arg, it, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "peek_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "peek_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "peek_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag != PL_TERM_VAR && code_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", code_term, &empty, "peek_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "peek_code", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "peek_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "peek_code", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)c); } } s->eos_past = (code == -1); pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, code); if (!unify_terms_wam(code_arg, it, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "put_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "put_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "put_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer"); } if (code_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", code_term, &empty, "put_code", ar); } const SLO code = code_term->v.int_value; if (!s->writable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "put_code", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "put_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "put_code", ar); } if (code < 0 || code > 255) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", "put_code", ar); } stream_write_char(s, id, (char)(unsigned char)code); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "unget_code") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *code_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "unget_code", 2); } code_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "unget_code", 2); } return cut_none(); } pl_term *code_term = deref_term_wam(code_arg); if (!code_term) { return cut_none(); } if (code_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer"); } if (code_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", code_term, &empty, "unget_code", ar); } const SLO code = code_term->v.int_value; if (code < -1) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character_code", "unget_code", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "unget_code", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "unget_code", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "unget_code", ar); } stream_pushback_push(s, vm->dbg_dat_ptr, code); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "get_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "get_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "get_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag != PL_TERM_VAR && ch_term->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character", ch_term, &empty, "get_char", ar); } if (ch_term->tag == PL_TERM_ATOM) { if (strcmp(ch_term->v.atom_name, "end_of_file") && (strlen(ch_term->v.atom_name) != 1)) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character", ch_term, &empty, "get_char", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "get_char", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "get_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "get_char", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (code == -1); pl_term *out_ch = NULL; if (code == -1) { out_ch = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "end_of_file"); } else { CHR tmp[2] = {(CHR)(unsigned char)code, '\0'}; out_ch = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, tmp); } if (!unify_terms_wam(char_arg, out_ch, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "peek_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "peek_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "peek_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag != PL_TERM_VAR && ch_term->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character", ch_term, &empty, "peek_char", ar); } if (ch_term->tag == PL_TERM_ATOM) { if (strcmp(ch_term->v.atom_name, "end_of_file") && (strlen(ch_term->v.atom_name) != 1)) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character", ch_term, &empty, "peek_char", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "peek_char", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "peek_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "peek_char", ar); } SLO code = -1; if (s->pushback_count) { code = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); code = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)c); } } s->eos_past = (code == -1); pl_term *out_ch = NULL; if (code == -1) { out_ch = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "end_of_file"); } else { CHR tmp[2] = {(CHR)(unsigned char)code, '\0'}; out_ch = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, tmp); } if (!unify_terms_wam(char_arg, out_ch, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "put_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "put_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "put_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character"); } if (ch_term->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", ch_term, &empty, "put_char", ar); } if (strlen(ch_term->v.atom_name) != 1) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character", ch_term, &empty, "put_char", ar); } if (!s->writable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "put_char", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "put_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "put_char", ar); } stream_write_char(s, id, (char)(unsigned char)ch_term->v.atom_name[0]); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "unget_char") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *char_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "unget_char", 2); } char_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "unget_char", 2); } return cut_none(); } pl_term *ch_term = deref_term_wam(char_arg); if (!ch_term) { return cut_none(); } if (ch_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character"); } if (ch_term->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character", ch_term, &empty, "unget_char", ar); } SLO code = -1; if (!strcmp(ch_term->v.atom_name, "end_of_file")) { code = -1; } else { if (strlen(ch_term->v.atom_name) != 1) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_character", ch_term, &empty, "unget_char", ar); } code = (SLO)(unsigned char)ch_term->v.atom_name[0]; } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "unget_char", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "unget_char", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "unget_char", ar); } stream_pushback_push(s, vm->dbg_dat_ptr, code); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "get_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "get_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "get_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag != PL_TERM_VAR && byte_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte", byte_term, &empty, "get_byte", ar); } if (byte_term->tag == PL_TERM_INT) { const SLO v = byte_term->v.int_value; if (v < -1 || v > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte", byte_term, &empty, "get_byte", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "get_byte", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "get_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "text_stream", sid, &empty, "get_byte", ar); } SLO byte = -1; if (s->pushback_count) { byte = s->pushback[--s->pushback_count]; } else { const int c = fgetc(s->fp); byte = (c == EOF) ? -1 : (SLO)(unsigned char)c; } s->eos_past = (byte == -1); pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, byte); if (!unify_terms_wam(byte_arg, it, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "peek_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "peek_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "peek_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag != PL_TERM_VAR && byte_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte", byte_term, &empty, "peek_byte", ar); } if (byte_term->tag == PL_TERM_INT) { const SLO v = byte_term->v.int_value; if (v < -1 || v > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte", byte_term, &empty, "peek_byte", ar); } } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "peek_byte", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "peek_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "text_stream", sid, &empty, "peek_byte", ar); } SLO byte = -1; if (s->pushback_count) { byte = s->pushback[s->pushback_count - 1]; } else { const int c = fgetc(s->fp); byte = (c == EOF) ? -1 : (SLO)(unsigned char)c; if (c != EOF) { stream_pushback_push(s, vm->dbg_dat_ptr, (SLO)(unsigned char)c); } } s->eos_past = (byte == -1); pl_term *it = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, byte); if (!unify_terms_wam(byte_arg, it, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "put_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "put_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "put_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer"); } if (byte_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", byte_term, &empty, "put_byte", ar); } const SLO byte = byte_term->v.int_value; if (byte < -1 || byte > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte", byte_term, &empty, "put_byte", ar); } if (!s->writable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "put_byte", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "put_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "text_stream", sid, &empty, "put_byte", ar); } stream_write_char(s, id, (char)(unsigned char)byte); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "unget_byte") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *byte_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "unget_byte", 2); } byte_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "unget_byte", 2); } return cut_none(); } pl_term *byte_term = deref_term_wam(byte_arg); if (!byte_term) { return cut_none(); } if (byte_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte"); } if (byte_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte", byte_term, &empty, "unget_byte", ar); } const SLO byte = byte_term->v.int_value; if (byte < -1 || byte > 255) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "in_byte", byte_term, &empty, "unget_byte", ar); } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "unget_byte", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "unget_byte", 1); } if (!s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "text_stream", sid, &empty, "unget_byte", ar); } stream_pushback_push(s, vm->dbg_dat_ptr, byte); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "read") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "read", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "read", 2); } return cut_none(); } if (!s->readable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "read", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "read", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "read", ar); } if (!solution_stream_wait_for_input(s)) { return cut_none(); } stream_flush_prompt_output_before_read(s, vm->rt_ctrl, vm->dbg_dat_ptr); const ULO term_base_line = s->line_count ? s->line_count : 1; const ULO term_base_col = s->line_pos ? s->line_pos : 1; const char *term_src_name = (s->file_name && s->file_name[0]) ? s->file_name : ((s->alias && s->alias[0]) ? s->alias : ""); pl_sbuf src; sbuf_init(&src, vm->rt_ctrl, vm->dbg_dat_ptr); const bool char_conv_on = vm->prog ? vm->prog->flag_char_conversion : false; const unsigned char *char_conv_table = vm->prog ? vm->prog->char_conv_table : NULL; const bool character_escapes = vm->prog ? vm->prog->flag_character_escapes : true; bool is_eof = false; const CHR *syntax_error_reason = NULL; const CHR *syntax_error_pos = NULL; if (!stream_read_term_src(s, &src, &is_eof, char_conv_on, char_conv_table, character_escapes, vm->dbg_dat_ptr, &syntax_error_reason, &syntax_error_pos)) { if (syntax_error_reason) { report_stream_syntax_error(term_src_name, term_base_line, term_base_col, src.buf, syntax_error_pos, syntax_error_reason); } sbuf_free(&src); if (syntax_error_reason) { return throw_syntax_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, syntax_error_reason, "read", ar); } return cut_none(); } pl_term *read_term_val = NULL; pl_scope *scope = NULL; if (is_eof) { read_term_val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "end_of_file"); } else { pl_parse p = {0}; p.src_name = term_src_name; p.src_base_line = term_base_line; p.src_base_col = term_base_col; p.rt_ctrl = vm->rt_ctrl; p.dbg_dat_ptr = vm->dbg_dat_ptr; p.ops = vm->prog ? vm->prog->op_overrides : NULL; p.double_quotes = vm->prog ? vm->prog->flag_double_quotes : PL_DQ_CHARS; p.character_escapes = character_escapes; lex_init(&p.lx, src.buf ? src.buf : "", char_conv_on, char_conv_table, character_escapes); pl_var_table vt = {0}; scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); read_term_val = parse_term(&p, &vt, scope, true, 1200); if (peek_tok(&p).type == TOK_DOT) { (void)take_tok(&p); } else { expect_tok(&p, TOK_DOT); } if (peek_tok(&p).type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected trailing tokens after read/1", vm->dbg_dat_ptr); } (void)wam_state_push_scope(vm->st, scope, vt.count, vm->rt_ctrl, vm->dbg_dat_ptr); } sbuf_free(&src); if (!unify_terms_wam(term_arg, read_term_val, &vm->st->trail, vm->dbg_dat_ptr)) { if (scope) { wam_state_pop_scope(vm->st, scope); } return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "read_term") && ((ar == 2) || (ar == 3)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_input; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; pl_term *opts_arg = goal->v.str.args[1]; if (ar == 3) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "read_term", 3); } term_arg = goal->v.str.args[1]; opts_arg = goal->v.str.args[2]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 3) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "read_term", 3); } return cut_none(); } if (!s->readable) { if (ar == 3) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", st_term, &empty, "read_term", 3); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "stream", cur, &empty, "read_term", 2); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "binary_stream", sid, &empty, "read_term", ar); } if (!solution_stream_wait_for_input(s)) { return cut_none(); } pl_term *opts_term = deref_term_wam(opts_arg); if (!opts_term) { return cut_none(); } if (opts_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list"); } if (!term_is_list_pair(opts_term) && !term_is_nil(opts_term)) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", opts_term, &empty, "read_term", ar); } pl_term *vars_target = NULL; pl_term *varnames_target = NULL; pl_term *singletons_target = NULL; bool character_escapes = vm->prog ? vm->prog->flag_character_escapes : true; pl_double_quotes_mode dq_mode = vm->prog ? vm->prog->flag_double_quotes : PL_DQ_CHARS; pl_term *opt_cur = opts_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, opt_cur); while (1) { opt_cur = deref_term_wam(opt_cur); if (term_is_nil(opt_cur)) { break; } if (opt_cur->tag == PL_TERM_VAR) { pl_env *env = alloc_empty_env_rt(vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *formal = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "read_term", ar); return except_to(frame->exc_barrier, make_error_rt(formal, ctx, vm->rt_ctrl, vm->dbg_dat_ptr), env); } if (!term_is_list_pair(opt_cur)) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", opts_term, &empty, "read_term", ar); } pl_term *opt = deref_term_wam(opt_cur->v.str.args[0]); if (!opt) { return cut_none(); } if (opt->tag == PL_TERM_VAR) { pl_env *env = alloc_empty_env_rt(vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *formal = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "read_term", ar); return except_to(frame->exc_barrier, make_error_rt(formal, ctx, vm->rt_ctrl, vm->dbg_dat_ptr), env); } if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "variables")) { vars_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "variable_names")) { varnames_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "singletons")) { singletons_target = opt->v.str.args[0]; } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "character_escapes")) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "read_option"); } if (v->tag != PL_TERM_ATOM || (strcmp(v->v.atom_name, "true") && strcmp(v->v.atom_name, "false"))) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } character_escapes = !strcmp(v->v.atom_name, "true"); } else if (opt->tag == PL_TERM_STRUCT && opt->v.str.arity == 1 && !strcmp(opt->v.str.functor, "double_quotes")) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { return cut_none(); } if (v->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "read_option"); } if (v->tag != PL_TERM_ATOM) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } if (!strcmp(v->v.atom_name, "atom")) { dq_mode = PL_DQ_ATOM; } else if (!strcmp(v->v.atom_name, "codes")) { dq_mode = PL_DQ_CODES; } else if (!strcmp(v->v.atom_name, "chars")) { dq_mode = PL_DQ_CHARS; } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } } else { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "read_option", opt, &empty, "read_term", ar); } opt_cur = opt_cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "read_term", ar); } } stream_flush_prompt_output_before_read(s, vm->rt_ctrl, vm->dbg_dat_ptr); const ULO term_base_line = s->line_count ? s->line_count : 1; const ULO term_base_col = s->line_pos ? s->line_pos : 1; const char *term_src_name = (s->file_name && s->file_name[0]) ? s->file_name : ((s->alias && s->alias[0]) ? s->alias : ""); pl_sbuf src; sbuf_init(&src, vm->rt_ctrl, vm->dbg_dat_ptr); const bool char_conv_on = vm->prog ? vm->prog->flag_char_conversion : false; const unsigned char *char_conv_table = vm->prog ? vm->prog->char_conv_table : NULL; bool is_eof = false; const CHR *syntax_error_reason = NULL; const CHR *syntax_error_pos = NULL; if (!stream_read_term_src(s, &src, &is_eof, char_conv_on, char_conv_table, character_escapes, vm->dbg_dat_ptr, &syntax_error_reason, &syntax_error_pos)) { if (syntax_error_reason) { report_stream_syntax_error(term_src_name, term_base_line, term_base_col, src.buf, syntax_error_pos, syntax_error_reason); } sbuf_free(&src); if (syntax_error_reason) { return throw_syntax_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, syntax_error_reason, "read_term", ar); } return cut_none(); } pl_term *read_term_val = NULL; pl_var_list vars_list = {0}; pl_var_list named_list = {0}; pl_var_list singletons_list = {0}; pl_scope *scope = NULL; if (is_eof) { read_term_val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "end_of_file"); } else { pl_parse p = {0}; p.src_name = term_src_name; p.src_base_line = term_base_line; p.src_base_col = term_base_col; p.rt_ctrl = vm->rt_ctrl; p.dbg_dat_ptr = vm->dbg_dat_ptr; p.ops = vm->prog ? vm->prog->op_overrides : NULL; p.double_quotes = dq_mode; p.character_escapes = character_escapes; lex_init(&p.lx, src.buf ? src.buf : "", char_conv_on, char_conv_table, character_escapes); pl_var_table vt = {0}; scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); read_term_val = parse_term(&p, &vt, scope, true, 1200); expect_tok(&p, TOK_DOT); if (peek_tok(&p).type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected trailing tokens after read_term/*", vm->dbg_dat_ptr); } (void)wam_state_push_scope(vm->st, scope, vt.count, vm->rt_ctrl, vm->dbg_dat_ptr); if (vars_target || varnames_target || singletons_target) { pl_var_stack stv; var_stack_init(&stv); var_list_init(&vars_list); term_collect_vars_tr(read_term_val, NULL, &stv, &vars_list, vm->dbg_dat_ptr, 0); var_stack_free(&stv); if (varnames_target || singletons_target) { var_list_init(&named_list); var_list_init(&singletons_list); pl_var_count_list counts; var_count_list_init(&counts); pl_var_stack st2; var_stack_init(&st2); term_count_vars_tr(read_term_val, NULL, &st2, &counts, vm->dbg_dat_ptr, 0); var_stack_free(&st2); for (ULO i = 0; i < counts.count; i++) { pl_term *v = counts.items[i].term; if (!v || v->tag != PL_TERM_VAR) { continue; } const CHR *nm = v->v.var.var_name; if (!nm || (nm[0] == '_' && nm[1] == '\0')) { continue; } var_list_add_unique(&named_list, vm->dbg_dat_ptr, counts.items[i].key, v); if (counts.items[i].count == 1) { var_list_add_unique(&singletons_list, vm->dbg_dat_ptr, counts.items[i].key, v); } } var_count_list_free(&counts); } } } sbuf_free(&src); const ULO mark = vm->st->trail.count; bool ok = unify_terms_wam(term_arg, read_term_val, &vm->st->trail, vm->dbg_dat_ptr); if (ok && vars_target) { pl_term *list = NULL; if (!vars_list.count) { list = make_nil_rt(vm->dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * vars_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } for (ULO i = 0; i < vars_list.count; i++) { elems[i] = vars_list.items[i].term; } list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, elems, vars_list.count); free(elems); } ok = unify_terms_wam(vars_target, list, &vm->st->trail, vm->dbg_dat_ptr); } if (ok && varnames_target) { pl_term *list = NULL; if (!named_list.count) { list = make_nil_rt(vm->dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * named_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } for (ULO i = 0; i < named_list.count; i++) { pl_term *v = named_list.items[i].term; pl_term *pair = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "=", 2); pair->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, v->v.var.var_name ? v->v.var.var_name : ""); pair->v.str.args[1] = v; elems[i] = pair; } list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, elems, named_list.count); free(elems); } ok = unify_terms_wam(varnames_target, list, &vm->st->trail, vm->dbg_dat_ptr); } if (ok && singletons_target) { pl_term *list = NULL; if (!singletons_list.count) { list = make_nil_rt(vm->dbg_dat_ptr); } else { pl_term **elems = (pl_term **)malloc(sizeof(pl_term *) * singletons_list.count); if (!elems) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", vm->dbg_dat_ptr); } for (ULO i = 0; i < singletons_list.count; i++) { pl_term *v = singletons_list.items[i].term; pl_term *pair = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "=", 2); pair->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, v->v.var.var_name ? v->v.var.var_name : ""); pair->v.str.args[1] = v; elems[i] = pair; } list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, elems, singletons_list.count); free(elems); } ok = unify_terms_wam(singletons_target, list, &vm->st->trail, vm->dbg_dat_ptr); } var_list_free(&vars_list); var_list_free(&named_list); var_list_free(&singletons_list); if (!ok) { wam_trail_unwind(&vm->st->trail, mark); if (scope) { wam_state_pop_scope(vm->st, scope); } return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "file_to_chars") && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *file = deref_term_wam(goal->v.str.args[0]); if (!file) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink", file, &empty, "file_to_chars", 2); } pl_term *chars = NULL; int io_errno = 0; const flowlog_file_chars_status stc = flowlog_file_to_chars_term(file->v.atom_name, vm->rt_ctrl, vm->dbg_dat_ptr, &chars, &io_errno); if (stc != FLOWLOG_FILE_CHARS_OK) { if (stc == FLOWLOG_FILE_CHARS_ERR_INVALID) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "character_code", "file_to_chars", 2); } if (stc == FLOWLOG_FILE_CHARS_ERR_TOO_LARGE) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "file_to_chars", 2); } if (io_errno == EACCES || io_errno == EPERM) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "open", "source_sink", file, &empty, "file_to_chars", 2); } if (stc == FLOWLOG_FILE_CHARS_ERR_OPEN) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink", file, &empty, "file_to_chars", 2); } return throw_permission_error( frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "source_sink", file, &empty, "file_to_chars", 2); } if (!unify_terms_wam(goal->v.str.args[1], chars, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if ((!strcmp(fn, "file_to_bytes") || !strcmp(fn, "file_to_byte")) && (ar == 2) && goal->v.str.args) { pl_env empty = {0}; pl_term *file = deref_term_wam(goal->v.str.args[0]); if (!file) { return cut_none(); } if (file->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink"); } if (file->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink", file, &empty, fn, 2); } pl_term *bytes = NULL; int io_errno = 0; const flowlog_file_bytes_status stc = flowlog_file_to_bytes_term(file->v.atom_name, vm->rt_ctrl, vm->dbg_dat_ptr, &bytes, &io_errno); if (stc != FLOWLOG_FILE_BYTES_OK) { if (stc == FLOWLOG_FILE_BYTES_ERR_TOO_LARGE) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", fn, 2); } if (io_errno == EACCES || io_errno == EPERM) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "open", "source_sink", file, &empty, fn, 2); } if (stc == FLOWLOG_FILE_BYTES_ERR_OPEN) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "source_sink", file, &empty, fn, 2); } return throw_permission_error( frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "input", "source_sink", file, &empty, fn, 2); } if (!unify_terms_wam(goal->v.str.args[1], bytes, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "write") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "write", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "write", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "write", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "write", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "write", ar); } pl_sbuf sb; sbuf_init(&sb, vm->rt_ctrl, vm->dbg_dat_ptr); pl_write_opts wopts = {.quoted = false, .ignore_ops = false, .numbervars = true}; pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, vm->dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(vm->prog ? vm->prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, vm->dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "writeq") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "writeq", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "writeq", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "writeq", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "writeq", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "writeq", ar); } pl_sbuf sb; sbuf_init(&sb, vm->rt_ctrl, vm->dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = false, .numbervars = true}; pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, vm->dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(vm->prog ? vm->prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, vm->dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "write_canonical") && ((ar == 1) || (ar == 2)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; if (ar == 2) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "write_canonical", 2); } term_arg = goal->v.str.args[1]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 2) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "write_canonical", 2); } return cut_none(); } if (!s->writable) { if (ar == 2) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "write_canonical", 2); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "write_canonical", 1); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "write_canonical", ar); } pl_sbuf sb; sbuf_init(&sb, vm->rt_ctrl, vm->dbg_dat_ptr); pl_write_opts wopts = {.quoted = true, .ignore_ops = true}; pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, vm->dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(vm->prog ? vm->prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, vm->dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "write_term") && ((ar == 2) || (ar == 3)) && goal->v.str.args) { pl_env empty = {0}; streams_init(vm->dbg_dat_ptr); SLO id = g_streams.current_output; pl_term *st_term = NULL; pl_term *term_arg = goal->v.str.args[0]; pl_term *opts_arg = goal->v.str.args[1]; if (ar == 3) { st_term = deref_term_wam(goal->v.str.args[0]); if (!st_term) { return cut_none(); } if (st_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream"); } if (!term_stream_id_wam(goal->v.str.args[0], vm->dbg_dat_ptr, &id)) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "write_term", 3); } term_arg = goal->v.str.args[1]; opts_arg = goal->v.str.args[2]; } pl_stream *s = NULL; if (!stream_lookup(id, &s, vm->dbg_dat_ptr)) { if (ar == 3) { return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "stream", st_term, &empty, "write_term", 3); } return cut_none(); } if (!s->writable) { if (ar == 3) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", st_term, &empty, "write_term", 3); } pl_term *cur = make_stream_term_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "stream", cur, &empty, "write_term", 2); } if (s->binary) { pl_term *sid = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, id); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "output", "binary_stream", sid, &empty, "write_term", ar); } pl_write_opts wopts = {.quoted = false, .ignore_ops = false}; pl_term *opts_term = deref_term_wam(opts_arg); if (!opts_term) { return cut_none(); } if (opts_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } pl_write_var_name_map vnames; write_var_name_map_init(&vnames); bool have_var_names = false; pl_term *cur = opts_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (term_is_nil(cur)) { break; } if (cur->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); pl_env *env = alloc_empty_env_rt(vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *formal = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "instantiation_error"); pl_term *ctx = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "write_term", ar); return except_to(frame->exc_barrier, make_error_rt(formal, ctx, vm->rt_ctrl, vm->dbg_dat_ptr), env); } if (!term_is_list_pair(cur)) { write_var_name_map_free(&vnames); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", cur, &empty, "write_term", ar); } pl_term *opt = deref_term_wam(cur->v.str.args[0]); if (!opt) { write_var_name_map_free(&vnames); return cut_none(); } if (opt->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } if (opt->tag != PL_TERM_STRUCT) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(opt->v.str.functor, "quoted") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.quoted = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.quoted = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "ignore_ops") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.ignore_ops = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.ignore_ops = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "numbervars") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.numbervars = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.numbervars = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "max_depth") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_INT) { write_var_name_map_free(&vnames); return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", v, &empty, "write_term", ar); } if (v->v.int_value < 0) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", v, &empty, "write_term", ar); } wopts.max_depth = (ULO)v->v.int_value; } else if (!strcmp(opt->v.str.functor, "fullstop") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.fullstop = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.fullstop = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "nl") && (opt->v.str.arity == 1)) { pl_term *v = deref_term_wam(opt->v.str.args[0]); if (!v) { write_var_name_map_free(&vnames); return cut_none(); } if (v->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option"); } if (v->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!strcmp(v->v.atom_name, "true")) { wopts.nl = true; } else if (!strcmp(v->v.atom_name, "false")) { wopts.nl = false; } else { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } } else if (!strcmp(opt->v.str.functor, "variable_names") && (opt->v.str.arity == 1)) { have_var_names = true; pl_term *names = deref_term_wam(opt->v.str.args[0]); if (!names) { write_var_name_map_free(&vnames); return cut_none(); } if (names->tag != PL_TERM_ATOM && names->tag != PL_TERM_STRUCT && names->tag != PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_term *lc = names; pl_list_cycle_guard cg2; list_cycle_guard_init(&cg2, lc); while (1) { lc = deref_term_wam(lc); if (!lc) { write_var_name_map_free(&vnames); return cut_none(); } if (term_is_nil(lc)) { break; } if (lc->tag == PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } if (!term_is_list_pair(lc)) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_term *pair = deref_term_wam(lc->v.str.args[0]); if (!pair || pair->tag != PL_TERM_STRUCT || pair->v.str.arity != 2 || strcmp(pair->v.str.functor, "=")) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_term *nm = deref_term_wam(pair->v.str.args[0]); if (!nm) { write_var_name_map_free(&vnames); return cut_none(); } if (nm->tag != PL_TERM_ATOM) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_term *var = pair->v.str.args[1]; if (!var || var->tag != PL_TERM_VAR) { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } pl_var_key k = {.scope = var->v.var.scope, .var_id = var->v.var.var_id}; write_var_name_add_unique(&vnames, vm->dbg_dat_ptr, k, nm->v.atom_name); lc = lc->v.str.args[1]; if (list_cycle_guard_step_wam(&cg2)) { write_var_name_map_free(&vnames); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "write_term", ar); } } } else { write_var_name_map_free(&vnames); return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "write_option", opt, &empty, "write_term", ar); } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { write_var_name_map_free(&vnames); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "write_term", ar); } } wopts.var_names = have_var_names ? &vnames : NULL; pl_sbuf sb; sbuf_init(&sb, vm->rt_ctrl, vm->dbg_dat_ptr); pl_var_stack seen; var_stack_init(&seen); pl_binding_vec binds; binding_vec_init(&binds); wam_collect_bindings_for_write_tr(term_arg, &seen, &binds, vm->dbg_dat_ptr, 0); pl_env wenv = {.items = binds.items, .count = binds.count, .cap = binds.count}; write_term_to_sbuf(vm->prog ? vm->prog->op_overrides : NULL, term_arg, &wenv, &wopts, &sb, vm->dbg_dat_ptr); binding_vec_free(&binds); var_stack_free(&seen); if (wopts.fullstop) { sbuf_append_char(&sb, '.'); } if (wopts.nl) { sbuf_append_char(&sb, '\n'); } if (sb.buf && sb.len) { stream_write_mem(s, id, sb.buf, sb.len); } sbuf_free(&sb); write_var_name_map_free(&vnames); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "current_prolog_flag") && (ar == 2) && goal->v.str.args) { pl_term *flag = deref_term_wam(goal->v.str.args[0]); if (!flag) { return cut_none(); } const pl_unknown_mode unknown_mode = vm->prog ? vm->prog->flag_unknown : PL_UNKNOWN_ERROR; const bool char_conv_on = vm->prog ? vm->prog->flag_char_conversion : false; const bool character_escapes = vm->prog ? vm->prog->flag_character_escapes : true; const bool occurs_check = vm->prog ? vm->prog->flag_occurs_check : false; const bool debug_on = vm->prog ? vm->prog->flag_debug : false; const bool par_or_on = vm->prog ? vm->prog->flag_parallel_or : false; const pl_or_order_mode par_or_order = vm->prog ? vm->prog->flag_parallel_or_order : PL_OR_ORDERED; const bool par_and_on = vm->prog ? vm->prog->flag_parallel_and : false; const SLO par_max_depth = vm->prog ? vm->prog->flag_parallel_max_depth : flowlog_default_parallel_max_depth_auto(); const SLO par_or_nesting = vm->prog ? vm->prog->flag_parallel_or_nesting : (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; const pl_double_quotes_mode dq_mode = vm->prog ? vm->prog->flag_double_quotes : PL_DQ_CHARS; const pl_engine_mode eng_mode = vm->prog ? vm->prog->flag_engine : PL_ENGINE_INTERP; const pl_engine_mode eng_active_mode = g_engine_active; const CHR *unknown_atom = "error"; if (unknown_mode == PL_UNKNOWN_WARNING) { unknown_atom = "warning"; } else if (unknown_mode == PL_UNKNOWN_FAIL) { unknown_atom = "fail"; } const CHR *dq_atom = "codes"; if (dq_mode == PL_DQ_ATOM) { dq_atom = "atom"; } else if (dq_mode == PL_DQ_CHARS) { dq_atom = "chars"; } const CHR *par_or_order_atom = (par_or_order == PL_OR_UNORDERED) ? "unordered" : "ordered"; const bool par_all_on = par_or_on && par_and_on && (par_max_depth > 0); const CHR *par_profile_atom = "custom"; if (!par_or_on && !par_and_on) { par_profile_atom = "off"; } else if (par_all_on) { par_profile_atom = (par_or_order == PL_OR_UNORDERED) ? "fast" : "iso"; } const CHR *engine_atom = "interp"; if (eng_mode == PL_ENGINE_WAM) { engine_atom = "wam"; } else if (eng_mode == PL_ENGINE_WAMVM) { engine_atom = "wamvm"; } const CHR *engine_active_atom = "interp"; if (eng_active_mode == PL_ENGINE_WAM) { engine_active_atom = "wam"; } else if (eng_active_mode == PL_ENGINE_WAMVM) { engine_active_atom = "wamvm"; } if (flag->tag == PL_TERM_VAR) { // Build a goal slice that represents the continuation after current_prolog_flag/2. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const bool release_temp = vm->release_temp; const pl_temp_mark outer_tm = release_temp ? temp_alloc_mark(g_temp_alloc) : (pl_temp_mark){0}; struct { const CHR *name; pl_term *value; } flags[] = { {"bounded", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "false")}, {"max_arity", make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, 255)}, {"integer_rounding_function", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "toward_zero")}, {"double_quotes", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, dq_atom)}, {"char_conversion", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, char_conv_on ? "on" : "off")}, {"character_escapes", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, character_escapes ? "true" : "false")}, {"occurs_check", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, occurs_check ? "true" : "false")}, {"debug", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, debug_on ? "on" : "off")}, {"flowlog_engine", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, engine_atom)}, {"flowlog_engine_active", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, engine_active_atom)}, {"flowlog_parallel", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_all_on ? "on" : "off")}, {"flowlog_parallel_profile", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_profile_atom)}, {"flowlog_parallel_or", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_or_on ? "on" : "off")}, {"flowlog_parallel_or_order", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_or_order_atom)}, {"flowlog_parallel_and", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_and_on ? "on" : "off")}, {"flowlog_parallel_max_depth", make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_max_depth)}, {"flowlog_parallel_or_nesting", make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_or_nesting)}, {"argv", flowlog_build_argv_term(vm->prog, vm->rt_ctrl, vm->dbg_dat_ptr)}, {"unknown", make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, unknown_atom)}, }; for (ULO i = 0; i < (sizeof(flags) / sizeof(flags[0])); i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } const ULO mark = vm->st->trail.count; pl_cut_signal r = cut_none(); pl_term *name_term = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, flags[i].name); if (unify_terms_wam(goal->v.str.args[0], name_term, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], flags[i].value, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark); if (r.except) { if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return r; } if (r.cut) { if (r.target == &g_halt_barrier) { if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); // fail: current_prolog_flag/2 handled the continuation itself } if (flag->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", flag, &empty, "$legacy_current_prolog_flag", 2); } pl_term *val = NULL; if (!strcmp(flag->v.atom_name, "bounded")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "false"); } else if (!strcmp(flag->v.atom_name, "max_arity")) { val = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, 255); } else if (!strcmp(flag->v.atom_name, "integer_rounding_function")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "toward_zero"); } else if (!strcmp(flag->v.atom_name, "double_quotes")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, dq_atom); } else if (!strcmp(flag->v.atom_name, "char_conversion")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, char_conv_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "character_escapes")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, character_escapes ? "true" : "false"); } else if (!strcmp(flag->v.atom_name, "occurs_check")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, occurs_check ? "true" : "false"); } else if (!strcmp(flag->v.atom_name, "debug")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, debug_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_engine")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, engine_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_engine_active")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, engine_active_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_all_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_profile")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_profile_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_or_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or_order")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_or_order_atom); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_and")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_and_on ? "on" : "off"); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_max_depth")) { val = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_max_depth); } else if (!strcmp(flag->v.atom_name, "flowlog_parallel_or_nesting")) { val = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, par_or_nesting); } else if (!strcmp(flag->v.atom_name, "argv")) { val = flowlog_build_argv_term(vm->prog, vm->rt_ctrl, vm->dbg_dat_ptr); } else if (!strcmp(flag->v.atom_name, "unknown")) { val = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, unknown_atom); } else { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "prolog_flag", flag, &empty, "$legacy_current_prolog_flag", 2); } if (!unify_terms_wam(goal->v.str.args[1], val, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "set_prolog_flag") && (ar == 2) && goal->v.str.args) { // ISO: set_prolog_flag(+Flag, +Value). pl_term *flag = deref_term_wam(goal->v.str.args[0]); pl_term *val = deref_term_wam(goal->v.str.args[1]); if (!flag || !val) { return cut_none(); } if (flag->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom"); } if (flag->tag != PL_TERM_ATOM) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", flag, &empty, "set_prolog_flag", 2); } if (val->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "var"); } const CHR *flag_name = flag->v.atom_name; if (!flag_name) { return cut_none(); } if (!strcmp(flag_name, "unknown")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "error") && strcmp(val->v.atom_name, "warning") && strcmp(val->v.atom_name, "fail"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "unknown"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { if (!strcmp(val->v.atom_name, "error")) { vm->prog->flag_unknown = PL_UNKNOWN_ERROR; } else if (!strcmp(val->v.atom_name, "warning")) { vm->prog->flag_unknown = PL_UNKNOWN_WARNING; } else { vm->prog->flag_unknown = PL_UNKNOWN_FAIL; } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "occurs_check")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "true") && strcmp(val->v.atom_name, "false"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "occurs_check"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_occurs_check = !strcmp(val->v.atom_name, "true"); g_unify_occurs_check = vm->prog->flag_occurs_check; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "char_conversion")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "char_conversion"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_char_conversion = !strcmp(val->v.atom_name, "on"); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "character_escapes")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "true") && strcmp(val->v.atom_name, "false"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "character_escapes"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_character_escapes = !strcmp(val->v.atom_name, "true"); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "double_quotes")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "atom") && strcmp(val->v.atom_name, "codes") && strcmp(val->v.atom_name, "chars"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "double_quotes"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { if (!strcmp(val->v.atom_name, "atom")) { vm->prog->flag_double_quotes = PL_DQ_ATOM; } else if (!strcmp(val->v.atom_name, "codes")) { vm->prog->flag_double_quotes = PL_DQ_CODES; } else { vm->prog->flag_double_quotes = PL_DQ_CHARS; } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "debug")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "debug"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_debug = !strcmp(val->v.atom_name, "on"); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_engine")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "interp") && strcmp(val->v.atom_name, "tree") && strcmp(val->v.atom_name, "wam") && strcmp(val->v.atom_name, "wamvm"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_engine"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { if (!strcmp(val->v.atom_name, "wam")) { vm->prog->flag_engine = PL_ENGINE_WAM; } else if (!strcmp(val->v.atom_name, "wamvm")) { vm->prog->flag_engine = PL_ENGINE_WAMVM; } else { vm->prog->flag_engine = PL_ENGINE_INTERP; } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_parallel")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_parallel"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { const bool on = !strcmp(val->v.atom_name, "on"); if (on) { vm->prog->flag_parallel_or = true; vm->prog->flag_parallel_and = true; if (vm->prog->flag_parallel_or_nesting <= 0) { vm->prog->flag_parallel_or_nesting = 1; } } else { vm->prog->flag_parallel_or = false; vm->prog->flag_parallel_and = false; } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_parallel_profile")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "off") && strcmp(val->v.atom_name, "iso") && strcmp(val->v.atom_name, "fast"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_parallel_profile"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { if (!strcmp(val->v.atom_name, "off")) { vm->prog->flag_parallel_or = false; vm->prog->flag_parallel_and = false; vm->prog->flag_parallel_or_order = PL_OR_ORDERED; vm->prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else if (!strcmp(val->v.atom_name, "iso")) { vm->prog->flag_parallel_or = true; vm->prog->flag_parallel_and = true; vm->prog->flag_parallel_or_order = PL_OR_ORDERED; vm->prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else { vm->prog->flag_parallel_or = true; vm->prog->flag_parallel_and = true; vm->prog->flag_parallel_or_order = PL_OR_UNORDERED; SLO nest = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST; const ULO ncpu = get_n_cpuproc(); if (ncpu >= 128) { nest = 8; } else if (ncpu >= 64) { nest = 4; } else if (ncpu >= 32) { nest = 2; } vm->prog->flag_parallel_or_nesting = nest; } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_parallel_or")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_parallel_or"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_parallel_or = !strcmp(val->v.atom_name, "on"); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_parallel_or_order")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "ordered") && strcmp(val->v.atom_name, "unordered"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_parallel_or_order"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_parallel_or_order = !strcmp(val->v.atom_name, "unordered") ? PL_OR_UNORDERED : PL_OR_ORDERED; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_parallel_and")) { if (val->tag != PL_TERM_ATOM || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_parallel_and"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_parallel_and = !strcmp(val->v.atom_name, "on"); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_parallel_max_depth")) { if (val->tag != PL_TERM_INT || val->v.int_value < 0) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_parallel_max_depth"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_parallel_max_depth = val->v.int_value; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "flowlog_parallel_or_nesting")) { if (val->tag != PL_TERM_INT || val->v.int_value < 0) { pl_env empty = {0}; pl_term *cul = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "+", 2); cul->v.str.args[0] = make_atom_rt(vm->rt_ctrl, vm->dbg_dat_ptr, "flowlog_parallel_or_nesting"); cul->v.str.args[1] = val; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "flag_value", cul, &empty, "set_prolog_flag", 2); } if (vm->prog) { vm->prog->flag_parallel_or_nesting = val->v.int_value; } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(flag_name, "bounded") || !strcmp(flag_name, "max_arity") || !strcmp(flag_name, "integer_rounding_function") || !strcmp(flag_name, "flowlog_engine_active")) { pl_env empty = {0}; return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "flag", flag, &empty, "set_prolog_flag", 2); } // Unrecognized flag: ISO says domain_error(prolog_flag, Flag). pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "prolog_flag", flag, &empty, "set_prolog_flag", 2); } if (!strcmp(fn, "clause") && (ar == 2) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *head_pat = deref_term_wam(goal->v.str.args[0]); pl_term *body_pat = deref_term_wam(goal->v.str.args[1]); if (!head_pat || !body_pat) { return cut_none(); } if (head_pat->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } pl_env empty = {0}; if (head_pat->tag != PL_TERM_ATOM && head_pat->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", head_pat, &empty, "clause", 2); } if (body_pat->tag != PL_TERM_VAR && body_pat->tag != PL_TERM_ATOM && body_pat->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", body_pat, &empty, "clause", 2); } const CHR *pred_name = (head_pat->tag == PL_TERM_ATOM) ? head_pat->v.atom_name : head_pat->v.str.functor; const ULO pred_arity = (head_pat->tag == PL_TERM_ATOM) ? 0 : head_pat->v.str.arity; if (!pred_name) { return cut_none(); } if (builtin_pred_defined(pred_name, pred_arity)) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "access", "private_procedure", pi, &empty, "clause", 2); } bool dyn = false; if (!prog_pred_defined(vm->prog, pred_name, pred_arity, &dyn)) { return cut_none(); } if (!dyn) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pred_name, pred_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "access", "private_procedure", pi, &empty, "clause", 2); } ULO snap_count = 0; prog_db_rlock(vm->prog); snap_count = vm->prog->clause_count; prog_db_runlock(vm->prog); if (!vm->prog->clauses || !snap_count) { return cut_none(); } // Build a goal slice that represents the continuation after clause/2. pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { return cut_none(); } const bool release_temp = vm->release_temp; const pl_temp_mark outer_tm = release_temp ? temp_alloc_mark(g_temp_alloc) : (pl_temp_mark){0}; for (ULO i = 1; i <= snap_count; i++) { if (flowlog_cancelled()) { break; } if (vm->stop_at_first && vm->sol_count && *vm->sol_count) { break; } pl_clause *cl = NULL; prog_db_rlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { cl = vm->prog->clauses[i]; } prog_db_runlock(vm->prog); if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, pred_name) || (h_arity != pred_arity)) { continue; } const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(vm->st, scope, cl->var_count, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, vm->dbg_dat_ptr, 0); pl_term **body_goals = NULL; if (cl->body_count) { body_goals = (pl_term **)pool_alloc(vm->rt_ctrl, sizeof(pl_term *) * cl->body_count, vm->dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = clone_term_with_scope_arena(cl->body[bi + 1], cl->scope, scope, &arena, vm->dbg_dat_ptr, 0); } } pl_term *body_term = build_conjunction_rt(vm->rt_ctrl, vm->dbg_dat_ptr, body_goals, cl->body_count); body_term = wrap_var_goals_rt(body_term, vm->rt_ctrl, vm->dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &vm->st->trail, vm->rt_ctrl, vm->dbg_dat_ptr); pl_cut_signal r = cut_none(); if (unify_terms_wam(goal->v.str.args[0], head, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[1], body_term, &vm->st->trail, vm->dbg_dat_ptr)) { pl_wamvm_barrier inner_bar = {.prev = frame->cut_barrier, .cp_base = 0}; r = solve_goals_wamvm_cb(vm->prog, vm->q, rest_goals, rest_count, vm->st, &inner_bar, frame->exc_barrier, frame->depth + 1, vm->stop_at_first, vm->out, vm->sol_count, vm->rt_ctrl, vm->dbg_dat_ptr, rest_cont); } wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; if (release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } if (r.except) { if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return r; } if (r.cut) { if (r.target == &g_halt_barrier) { if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return r; } if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } break; } } if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); // fail: clause/2 handled the continuation itself } if (!strcmp(fn, "abolish") && (ar == 1) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *pi = deref_term_wam(goal->v.str.args[0]); if (!pi) { return cut_none(); } if (pi->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator"); } pl_env empty = {0}; if (pi->tag != PL_TERM_STRUCT || !pi->v.str.functor || strcmp(pi->v.str.functor, "/") || pi->v.str.arity != 2 || !pi->v.str.args) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator", pi, &empty, "abolish", 1); } pl_term *name = deref_term_wam(pi->v.str.args[0]); pl_term *arity_term = deref_term_wam(pi->v.str.args[1]); if (!name || !arity_term) { return cut_none(); } if (name->tag == PL_TERM_VAR || arity_term->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "predicate_indicator"); } if (name->tag != PL_TERM_ATOM) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "atom", name, &empty, "abolish", 1); } if (arity_term->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", arity_term, &empty, "abolish", 1); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0) { return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", arity_term, &empty, "abolish", 1); } const SLO max_arity = 255; if (arity_val > max_arity) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "max_arity", "abolish", 1); } bool dyn = false; const bool builtin = builtin_pred_defined(name->v.atom_name, (ULO)arity_val); const bool defined = prog_pred_defined(vm->prog, name->v.atom_name, (ULO)arity_val, &dyn); if (builtin || (defined && !dyn)) { return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "abolish", 1); } ULO snap_count = 0; prog_db_rlock(vm->prog); snap_count = vm->prog->clause_count; prog_db_runlock(vm->prog); bool changed = false; if (vm->prog->clauses && snap_count) { for (ULO i = 1; i <= snap_count; i++) { pl_clause *cl = NULL; prog_db_rlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { cl = vm->prog->clauses[i]; } prog_db_runlock(vm->prog); if (!cl || !cl->head) { continue; } const pl_term *h = cl->head; const CHR *fn_name = NULL; ULO fn_arity = 0; if (h->tag == PL_TERM_ATOM) { fn_name = h->v.atom_name; fn_arity = 0; } else if (h->tag == PL_TERM_STRUCT) { fn_name = h->v.str.functor; fn_arity = h->v.str.arity; } else { continue; } if (!fn_name || strcmp(fn_name, name->v.atom_name) || (fn_arity != (ULO)arity_val)) { continue; } prog_db_wlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { vm->prog->clauses[i] = NULL; } if (!changed) { prog_index_invalidate(vm->prog); changed = true; } prog_db_wunlock(vm->prog); } } prog_dyn_pred_remove(vm->prog, name->v.atom_name, (ULO)arity_val); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Dynamic database predicates (ISO core). if ((!strcmp(fn, "asserta") || !strcmp(fn, "assertz") || !strcmp(fn, "assert")) && (ar == 1) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *clause_in = deref_term_wam(goal->v.str.args[0]); if (!clause_in) { return cut_none(); } if (clause_in->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 1); } pl_term *head_in = clause_in; pl_term *body_in = NULL; if (clause_in->tag == PL_TERM_STRUCT && clause_in->v.str.arity == 2 && !strcmp(clause_in->v.str.functor, ":-")) { head_in = deref_term_wam(clause_in->v.str.args[0]); body_in = deref_term_wam(clause_in->v.str.args[1]); } if (!head_in) { return cut_none(); } if (head_in->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, fn, 1); } pl_env empty = {0}; if (head_in->tag != PL_TERM_ATOM && head_in->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", head_in, &empty, fn, 1); } const CHR *target_name = (head_in->tag == PL_TERM_ATOM) ? head_in->v.atom_name : head_in->v.str.functor; const ULO target_arity = (head_in->tag == PL_TERM_ATOM) ? 0 : head_in->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, target_name, target_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi, &empty, fn, 1); } bool dyn = false; const bool defined = prog_pred_defined(vm->prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, target_name, target_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi, &empty, fn, 1); } pl_term **body0 = NULL; ULO body_count = 0; ULO body_cap = 0; if (body_in) { pl_term *bd = deref_term_wam(body_in); const bool is_true = bd && (bd->tag == PL_TERM_ATOM) && bd->v.atom_name && !strcmp(bd->v.atom_name, "true"); if (!is_true) { pl_parse tmp = {0}; tmp.rt_ctrl = vm->rt_ctrl; tmp.dbg_dat_ptr = vm->dbg_dat_ptr; flatten_conjunction_goals(&tmp, body_in, &body0, &body_count, &body_cap); if (body_count == 1) { pl_term *only = deref_term_wam(body0[0]); if (only && (only->tag == PL_TERM_ATOM) && only->v.atom_name && !strcmp(only->v.atom_name, "true")) { body_count = 0; } } } } for (ULO i = 0; i < body_count; i++) { pl_term *bad = find_noncallable_goal_wam(body0[i], 0); if (bad) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", bad, &empty, fn, 1); } } // Dynamic database updates are permanent side-effects: allocate their clause/term structures outside of the query // temporary allocator so they survive backtracking and long-running loops (e.g. ISO test harness). pl_temp_alloc *saved_tmp = temp_alloc_suspend(); pl_clause *cl = (pl_clause *)pool_alloc(vm->rt_ctrl, sizeof(*cl), vm->dbg_dat_ptr); memset(cl, 0, sizeof(*cl)); pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); cl->scope = scope; pl_env *cl_env = (pl_env *)pool_alloc(vm->rt_ctrl, sizeof(*cl_env), vm->dbg_dat_ptr); memset(cl_env, 0, sizeof(*cl_env)); cl->env = cl_env; pl_wam_copy_ctx cctx = {0}; cctx.rt_ctrl = vm->rt_ctrl; cctx.dbg_dat_ptr = vm->dbg_dat_ptr; copy_var_map_init(&cctx.map, scope); cl->head = copy_term_wam_tr(head_in, &cctx, 0); cl->body_count = body_count; if (body_count) { cl->body = (pl_term **)pool_alloc(vm->rt_ctrl, sizeof(pl_term *) * (body_count + 1), vm->dbg_dat_ptr); cl->body[0] = NULL; for (ULO i = 0; i < body_count; i++) { cl->body[i + 1] = copy_term_wam_tr(body0[i], &cctx, 0); } } cl->var_count = cctx.map.next_var_id; const ULO nvars = cctx.map.next_var_id; if (cctx.bindings && nvars) { for (ULO i = 0; i < nvars && i < cctx.bindings_cap; i++) { if (cctx.bindings[i]) { env_bind(cl_env, vm->rt_ctrl, vm->dbg_dat_ptr, scope, i, cctx.bindings[i]); } } } copy_var_map_free(&cctx.map); free(cctx.bindings); cctx.bindings = NULL; cctx.bindings_cap = 0; clause_compute_tpl_sizes(cl); if (vm->prog && cl->head) { const CHR *pred_name = NULL; ULO pred_arity = 0; if (cl->head->tag == PL_TERM_ATOM) { pred_name = cl->head->v.atom_name; pred_arity = 0; } else if (cl->head->tag == PL_TERM_STRUCT) { pred_name = cl->head->v.str.functor; pred_arity = cl->head->v.str.arity; } if (pred_name) { prog_dyn_pred_add(vm->prog, pred_name, pred_arity, vm->rt_ctrl, vm->dbg_dat_ptr); } } const bool at_front = !strcmp(fn, "asserta"); prog_insert_clause(vm->prog, cl, at_front, vm->rt_ctrl, vm->dbg_dat_ptr); temp_alloc_resume(saved_tmp); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "retractall") && (ar == 1) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *pat_head = deref_term_wam(goal->v.str.args[0]); if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "retractall", 1); } if (pat_head->tag == PL_TERM_STRUCT && pat_head->v.str.arity == 2 && !strcmp(pat_head->v.str.functor, ":-")) { pat_head = deref_term_wam(pat_head->v.str.args[0]); } if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "retractall", 1); } pl_env empty = {0}; if (pat_head->tag != PL_TERM_ATOM && pat_head->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", pat_head, &empty, "retractall", 1); } const CHR *target_name = (pat_head->tag == PL_TERM_ATOM) ? pat_head->v.atom_name : pat_head->v.str.functor; const ULO target_arity = (pat_head->tag == PL_TERM_ATOM) ? 0 : pat_head->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, target_name, target_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retractall", 1); } bool dyn = false; const bool defined = prog_pred_defined(vm->prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, target_name, target_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retractall", 1); } ULO snap_count = 0; prog_db_rlock(vm->prog); snap_count = vm->prog->clause_count; prog_db_runlock(vm->prog); bool changed = false; if (defined && vm->prog->clauses && snap_count) { for (ULO i = 1; i <= snap_count; i++) { pl_clause *cl = NULL; prog_db_rlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { cl = vm->prog->clauses[i]; } prog_db_runlock(vm->prog); if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, target_name) || (h_arity != target_arity)) { continue; } pl_temp_mark tm = {0}; if (vm->release_temp) { tm = temp_alloc_mark(g_temp_alloc); } const ULO mark = vm->st->trail.count; const ULO scope_mark = vm->st->scope_count; pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(vm->st, scope, cl->var_count, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, vm->dbg_dat_ptr, 0); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &vm->st->trail, vm->rt_ctrl, vm->dbg_dat_ptr); const bool match = unify_terms_wam(pat_head, head, &vm->st->trail, vm->dbg_dat_ptr); wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = scope_mark; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, tm, vm->rt_ctrl, vm->dbg_dat_ptr); } if (!match) { continue; } prog_db_wlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { vm->prog->clauses[i] = NULL; } if (!changed) { prog_index_invalidate(vm->prog); changed = true; } prog_db_wunlock(vm->prog); } } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "retract") && (ar == 1) && goal->v.str.args) { if (!vm->prog) { return cut_none(); } pl_term *pat = deref_term_wam(goal->v.str.args[0]); if (!pat) { return cut_none(); } if (pat->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "retract", 1); } pl_term *pat_head = pat; pl_term *pat_body = NULL; const bool pat_is_rule = pat->tag == PL_TERM_STRUCT && pat->v.str.arity == 2 && !strcmp(pat->v.str.functor, ":-"); if (pat_is_rule) { pat_head = deref_term_wam(pat->v.str.args[0]); pat_body = deref_term_wam(pat->v.str.args[1]); } if (!pat_head) { return cut_none(); } if (pat_head->tag == PL_TERM_VAR) { return throw_instantiation_error_pi(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "retract", 1); } pl_env empty = {0}; if (pat_head->tag != PL_TERM_ATOM && pat_head->tag != PL_TERM_STRUCT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "callable", pat_head, &empty, "retract", 1); } const CHR *target_name = (pat_head->tag == PL_TERM_ATOM) ? pat_head->v.atom_name : pat_head->v.str.functor; const ULO target_arity = (pat_head->tag == PL_TERM_ATOM) ? 0 : pat_head->v.str.arity; if (builtin_pred_defined(target_name, target_arity)) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, target_name, target_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retract", 1); } bool dyn = false; const bool defined = prog_pred_defined(vm->prog, target_name, target_arity, &dyn); if (defined && !dyn) { pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, target_name, target_arity); return throw_permission_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "modify", "static_procedure", pi, &empty, "retract", 1); } if (!defined) { return cut_none(); } const ULO call_trail = vm->st->trail.count; const ULO call_scope = vm->st->scope_count; pl_temp_mark call_tm = {0}; if (vm->release_temp) { call_tm = temp_alloc_mark(g_temp_alloc); } ULO snap_count = 0; prog_db_rlock(vm->prog); snap_count = vm->prog->clause_count; prog_db_runlock(vm->prog); const ULO pc_after = frame->pc + 1; for (ULO i = 1; i <= snap_count; i++) { // Ensure we are at the call entry state for this attempt. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, call_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } pl_clause *cl = NULL; prog_db_rlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { cl = vm->prog->clauses[i]; } prog_db_runlock(vm->prog); if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, target_name) || (h_arity != target_arity)) { continue; } // ISO: retract(Head) matches only facts (Body=true). if (!pat_is_rule && cl->body_count) { continue; } pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(vm->st, scope, cl->var_count, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, vm->dbg_dat_ptr, 0); pl_term *body_term = NULL; if (pat_is_rule) { pl_term **body_goals = NULL; if (cl->body_count) { body_goals = (pl_term **)pool_alloc(vm->rt_ctrl, sizeof(pl_term *) * cl->body_count, vm->dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = clone_term_with_scope_arena(cl->body[bi + 1], cl->scope, scope, &arena, vm->dbg_dat_ptr, 0); } } body_term = build_conjunction_rt(vm->rt_ctrl, vm->dbg_dat_ptr, body_goals, cl->body_count); body_term = wrap_var_goals_rt(body_term, vm->rt_ctrl, vm->dbg_dat_ptr, 0); } wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &vm->st->trail, vm->rt_ctrl, vm->dbg_dat_ptr); bool ok = false; if (pat_is_rule) { ok = unify_terms_wam(pat_head, head, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(pat_body, body_term, &vm->st->trail, vm->dbg_dat_ptr); } else { ok = unify_terms_wam(pat_head, head, &vm->st->trail, vm->dbg_dat_ptr); } if (!ok) { continue; } // Permanent side-effect: once a clause is retracted, it stays retracted even if we backtrack. prog_db_wlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { vm->prog->clauses[i] = NULL; } prog_index_invalidate(vm->prog); prog_db_wunlock(vm->prog); // Advance past the retract/1 call in the current frame. frame->pc = pc_after; // If there may be more matching clauses later, keep a choicepoint. if (i + 1 <= snap_count) { wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *cp = &vm->cps[vm->cp_count++]; memset(cp, 0, sizeof(*cp)); cp->kind = PL_WAMVM_CP_RETRACT; cp->frame_count = vm->frame_count; cp->frame_pc = pc_after; cp->frame_cut_barrier = frame->cut_barrier; cp->frame_exc_barrier = frame->exc_barrier; cp->frame_depth = frame->depth; cp->trail_mark = call_trail; cp->scope_mark = call_scope; cp->tmp_mark = call_tm; cp->u.retract.target_name = target_name; cp->u.retract.target_arity = target_arity; cp->u.retract.pattern = goal->v.str.args[0]; cp->u.retract.next_i = i + 1; cp->u.retract.snap_count = snap_count; wamvm_vm_cp_snapshot_capture(vm, cp); } if (out_ok) { *out_ok = 1; } return cut_none(); } // No match: restore call entry state and fail. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, call_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); } // List operations (de-facto standard, used heavily by examples). // // Fast pruning helper for search-heavy examples. // // bounds_possible(+SortedInts, +K, +Target) if (!strcmp(fn, "bounds_possible") && (ar == 3) && goal->v.str.args) { pl_term *list0 = deref_term_wam(goal->v.str.args[0]); pl_term *k0 = deref_term_wam(goal->v.str.args[1]); pl_term *t0 = deref_term_wam(goal->v.str.args[2]); if (!list0 || !k0 || !t0) { return cut_none(); } pl_env empty = {0}; if (k0->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", k0, &empty, "bounds_possible", 3); } if (t0->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", t0, &empty, "bounds_possible", 3); } const SLO k = k0->v.int_value; const SLO target = t0->v.int_value; if (k <= 0) { if (target == 0) { frame->pc++; if (out_ok) { *out_ok = 1; } } return cut_none(); } if (k > 256) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "bounds_possible", 3); } SLO min_sum = 0; SLO last_sum = 0; SLO ring[256]; ULO ring_count = 0; ULO ring_pos = 0; pl_term *cur = list0; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); ULO count = 0; while (1) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", list0, &empty, "bounds_possible", 3); } pl_term *h = deref_term_wam(cur->v.str.args[0]); if (!h) { return cut_none(); } if (h->tag != PL_TERM_INT) { return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", h, &empty, "bounds_possible", 3); } const SLO v = h->v.int_value; count++; if ((SLO)count <= k) { min_sum += v; } if (ring_count < (ULO)k) { ring[ring_count++] = v; last_sum += v; } else { last_sum -= ring[ring_pos]; ring[ring_pos] = v; last_sum += v; ring_pos++; if (ring_pos >= (ULO)k) { ring_pos = 0; } } cur = cur->v.str.args[1]; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "bounds_possible", 3); } } if ((SLO)count < k) { return cut_none(); } const SLO max_sum = last_sum; if (target < min_sum || target > max_sum) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "keysort") && (ar == 2) && goal->v.str.args) { pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[0], &v, vm->dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st_list == PL_LIST_STATUS_TYPE_ERROR) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[0], &empty, "keysort", 2); } if (v.count) { for (ULO i = 0; i < v.count; i++) { pl_term *t = deref_term_wam(v.items[i]); if (!t) { term_vec_free(&v); return cut_none(); } if (t->tag == PL_TERM_VAR) { term_vec_free(&v); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if ((t->tag != PL_TERM_STRUCT) || (t->v.str.arity != 2) || strcmp(t->v.str.functor, "-")) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "pair", t, &empty, "keysort", 2); } v.items[i] = t; } // Stable insertion sort by Key (first arg). for (ULO i = 1; i < v.count; i++) { pl_term *pair = v.items[i]; pl_term *key = pair->v.str.args[0]; ULO j = i; while (j > 0) { pl_term *prev = v.items[j - 1]; pl_term *prev_key = prev->v.str.args[0]; if (compare_std_terms_wam(prev_key, key, vm->dbg_dat_ptr) <= 0) { break; } v.items[j] = prev; j--; } v.items[j] = pair; } } // Validate output argument is list/partial list and (if given) a list of pairs. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term_wam(out0); if (!out_term) { term_vec_free(&v); return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", out0, &empty, "keysort", 2); } pl_term *h = NULL; pl_term *tail = NULL; if (!term_list_like_uncons_rt(cur, &h, &tail, vm->rt_ctrl, vm->dbg_dat_ptr) || !h || !tail) { term_vec_free(&v); return cut_none(); } pl_term *e = deref_term_wam(h); if (!e) { term_vec_free(&v); return cut_none(); } if (e->tag != PL_TERM_VAR) { if ((e->tag != PL_TERM_STRUCT) || (e->v.str.arity != 2) || strcmp(e->v.str.functor, "-")) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "pair", e, &empty, "keysort", 2); } } cur = tail; if (list_cycle_guard_step_wam(&cg)) { term_vec_free(&v); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "keysort", 2); } } } pl_term *list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, v.items, v.count); term_vec_free(&v); if (!unify_terms_wam(goal->v.str.args[1], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "sort") && (ar == 2) && goal->v.str.args) { pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[0], &v, vm->dbg_dat_ptr); if (st_list == PL_LIST_STATUS_INSTANTIATION) { term_vec_free(&v); return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_sufficiently_instantiated"); } if (st_list == PL_LIST_STATUS_TYPE_ERROR) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", goal->v.str.args[0], &empty, "sort", 2); } // Validate output argument is list/partial list. pl_term *out0 = goal->v.str.args[1]; pl_term *out_term = deref_term_wam(out0); if (!out_term) { term_vec_free(&v); return cut_none(); } if (out_term->tag != PL_TERM_VAR) { pl_term *cur = out_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { cur = deref_term_wam(cur); if (!cur) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_like_pair(cur)) { term_vec_free(&v); pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", out0, &empty, "sort", 2); } ULO run_len = 0; const pl_term *run_tail = NULL; if (!term_list_like_run_len_and_tail_const(cur, &run_len, &run_tail)) { term_vec_free(&v); return cut_none(); } cur = (pl_term *)(run_tail ? run_tail : make_nil_rt(vm->dbg_dat_ptr)); if (list_cycle_guard_step_wam(&cg)) { term_vec_free(&v); return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "sort", 2); } } } if (v.count) { g_qsort_wam_dbg_dat_ptr = vm->dbg_dat_ptr; qsort(v.items, (size_t)v.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp_wam); g_qsort_wam_dbg_dat_ptr = NULL; } ULO uniq = 0; for (ULO i = 0; i < v.count; i++) { if (!uniq || (compare_std_terms_wam(v.items[i], v.items[uniq - 1], vm->dbg_dat_ptr) != 0)) { v.items[uniq++] = v.items[i]; } } pl_term *list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, v.items, uniq); term_vec_free(&v); if (!unify_terms_wam(goal->v.str.args[1], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } if (!strcmp(fn, "msort") && (ar == 2) && goal->v.str.args) { pl_term_vec v = {0}; const pl_list_status st_list = list_to_vec_iso_wam(goal->v.str.args[0], &v, vm->dbg_dat_ptr); if (st_list != PL_LIST_STATUS_OK) { term_vec_free(&v); return cut_none(); } if (v.count) { g_qsort_wam_dbg_dat_ptr = vm->dbg_dat_ptr; qsort(v.items, (size_t)v.count, sizeof(pl_term *), qsort_pl_term_ptr_cmp_wam); g_qsort_wam_dbg_dat_ptr = NULL; } pl_term *list = build_list_rt(vm->rt_ctrl, vm->dbg_dat_ptr, v.items, v.count); term_vec_free(&v); if (!unify_terms_wam(goal->v.str.args[1], list, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Internal helper for WAMVM OR-par chunk jobs: like select1/3, but only yields // elements in the half-open index range [Start, End). if (!strcmp(fn, "$select1_range") && (ar == 5) && goal->v.str.args) { pl_term *list0 = deref_term_wam(goal->v.str.args[1]); if (!list0) { return cut_none(); } pl_term *start0 = deref_term_wam(goal->v.str.args[3]); pl_term *end0 = deref_term_wam(goal->v.str.args[4]); if (!start0 || !end0 || start0->tag != PL_TERM_INT || end0->tag != PL_TERM_INT) { pl_env empty = {0}; pl_term *cul = (!start0 || (start0->tag != PL_TERM_INT)) ? start0 : end0; if (!cul) { cul = start0 ? start0 : end0; } return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", cul, &empty, "$select1_range", 5); } if (start0->v.int_value < 0 || end0->v.int_value < 0) { return cut_none(); } const ULO start_idx = (ULO)start0->v.int_value; const ULO end_idx = (ULO)end0->v.int_value; if (start_idx >= end_idx) { return cut_none(); } if (term_is_nil(list0)) { return cut_none(); } if (!term_is_list_pair(list0)) { return cut_none(); } const CHR *cons_functor = list0->v.str.functor; const bool release_temp = vm->release_temp; const ULO call_trail = vm->st->trail.count; const ULO call_scope = vm->st->scope_count; const pl_temp_mark outer_tm = release_temp ? temp_alloc_mark(g_temp_alloc) : (pl_temp_mark){0}; pl_term *prefix[256]; size_t prefix_count = 0; pl_term *cur = list0; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); for (ULO idx = 0;; idx++) { if (flowlog_cancelled()) { break; } if (idx >= end_idx) { break; } cur = deref_term_wam(cur); if (!cur) { break; } if (term_is_nil(cur) || (cur->tag == PL_TERM_VAR)) { break; } if (!term_is_list_pair(cur)) { break; } pl_term *head = cur->v.str.args[0]; pl_term *tail = cur->v.str.args[1]; if (idx < start_idx) { if (prefix_count < (sizeof(prefix) / sizeof(prefix[0]))) { prefix[prefix_count++] = head; } else { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "$select1_range", 5); } cur = tail; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "$select1_range", 5); } continue; } pl_term *rest = wamvm_vm_select1_build_rest(vm, cons_functor, (pl_term *const *)prefix, prefix_count, tail); if (unify_terms_wam(goal->v.str.args[0], head, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], rest, &vm->st->trail, vm->dbg_dat_ptr)) { const ULO pc_after = frame->pc + 1; frame->pc = pc_after; bool more = false; if ((idx + 1) < end_idx) { pl_term *next = deref_term_wam(tail); more = (next && !term_is_nil(next) && (next->tag != PL_TERM_VAR)); } if (more) { wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *cp = &vm->cps[vm->cp_count++]; memset(cp, 0, sizeof(*cp)); cp->kind = PL_WAMVM_CP_SELECT1; cp->frame_count = vm->frame_count; cp->frame_pc = pc_after; cp->frame_cut_barrier = frame->cut_barrier; cp->frame_exc_barrier = frame->exc_barrier; cp->frame_depth = frame->depth; cp->trail_mark = call_trail; cp->scope_mark = call_scope; cp->tmp_mark = outer_tm; cp->u.select1.goal = goal; cp->u.select1.list0 = list0; cp->u.select1.cons_functor = cons_functor; cp->u.select1.next_idx = idx + 1; cp->u.select1.end_idx = end_idx; cp->u.select1.cycle_start = 0; cp->u.select1.cycle_len = 0; cp->u.select1.more = 1; wamvm_vm_cp_snapshot_capture(vm, cp); } if (out_ok) { *out_ok = 1; } return cut_none(); } // Restore to the call entry state before trying the next element. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } if (prefix_count < (sizeof(prefix) / sizeof(prefix[0]))) { prefix[prefix_count++] = head; } else { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "$select1_range", 5); } cur = tail; if (list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "$select1_range", 5); } } // No alternative matched in the given range: restore and fail. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); } if ((!strcmp(fn, "select1") || !strcmp(fn, "select_") || !strcmp(fn, "select")) && (ar == 3) && goal->v.str.args) { pl_term *list0 = deref_term_wam(goal->v.str.args[1]); if (!list0) { return cut_none(); } if (term_is_nil(list0)) { return cut_none(); } if (!term_is_list_pair(list0)) { pl_term *rel = build_select_relational_rt(vm->rt_ctrl, vm->dbg_dat_ptr, fn, goal->v.str.args[0], goal->v.str.args[1], goal->v.str.args[2]); frame->pc++; wamvm_vm_push_frame_goal1(vm, rel, frame->cut_barrier, frame->exc_barrier, frame->depth + 1); if (out_ok) { *out_ok = 1; } return cut_none(); } const CHR *cons_functor = list0->v.str.functor; pl_list_cycle_info cycle = {0}; const bool has_cycle = list_pair_cycle_info_wam(list0, &cycle); const ULO cycle_start = has_cycle ? cycle.prefix_len : 0; const ULO cycle_end = has_cycle ? (cycle.prefix_len + cycle.cycle_len) : 0; const bool release_temp = vm->release_temp; const ULO call_trail = vm->st->trail.count; const ULO call_scope = vm->st->scope_count; const pl_temp_mark outer_tm = release_temp ? temp_alloc_mark(g_temp_alloc) : (pl_temp_mark){0}; pl_term *const *rest_goals = NULL; ULO rest_count = 0; const pl_wam_cont *rest_cont = NULL; // OR-par split: for large enough lists, treat select1/3 as a high-quality choicepoint for work-stealing OR-par. bool can_orpar = vm->prog && g_par_state && (g_table_state == NULL) && ((SLO)g_orpar_level <= vm->prog->flag_parallel_or_nesting) && vm->prog->flag_parallel_or && (vm->prog->flag_parallel_max_depth > 0) && !vm->stop_at_first; if (can_orpar && g_par_budget) { if (atomic_load_explicit(g_par_budget, memory_order_relaxed) <= 0) { can_orpar = false; } } if (has_cycle) { can_orpar = false; } ULO alt_count = 0; if (can_orpar) { pl_term *lc = list0; while (1) { lc = deref_term_wam(lc); if (!lc) { return cut_none(); } if (term_is_nil(lc)) { break; } if (!term_is_list_pair(lc)) { break; } alt_count++; lc = lc->v.str.args[1]; } } const bool par_or = can_orpar && (alt_count >= (ULO)FLOWLOG_SELECT1_ORPAR_DEEP_THRESHOLD); if (par_or && (alt_count >= FLOWLOG_ORPAR_MIN_ALT_THRESHOLD)) { const uint64_t orpar_t0 = flowlog_monotonic_ns(); const CHR *pred = "select1"; const ULO pred_arity = 3; ULO worker_count = (ULO)g_par_state->max_threads; if (worker_count < 2) { worker_count = 2; } if (worker_count > alt_count) { worker_count = alt_count; } int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } if (worker_count >= 2) { ULO chunk_count = worker_count * 128; const ULO chunk_cap = 16384; if (chunk_count > chunk_cap) { chunk_count = chunk_cap; } if (chunk_count > alt_count) { chunk_count = alt_count; } if (!chunk_count) { chunk_count = alt_count; } // Build a goal slice that represents the continuation after select1/3 in the current VM. if (!wamvm_vm_build_cont_after_goal(vm, frame, frame->pc + 1, &rest_goals, &rest_count, &rest_cont, vm->rt_ctrl, vm->dbg_dat_ptr)) { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); } flowlog_debug_orpar_log_start(pred, pred_arity, alt_count, worker_count, chunk_count, frame->depth, vm->stop_at_first); pl_or_job *workers = (pl_or_job *)pool_alloc(vm->rt_ctrl, sizeof(*workers) * worker_count, vm->dbg_dat_ptr); memset(workers, 0, sizeof(*workers) * worker_count); pl_or_job *chunks = (pl_or_job *)pool_alloc(vm->rt_ctrl, sizeof(*chunks) * chunk_count, vm->dbg_dat_ptr); memset(chunks, 0, sizeof(*chunks) * chunk_count); pl_or_work *work = (pl_or_work *)pool_alloc(vm->rt_ctrl, sizeof(*work), vm->dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->count = worker_count; work->jobs = workers; work->chunk_count = chunk_count; work->chunks = chunks; work->unordered = (vm->prog->flag_parallel_or_order == PL_OR_UNORDERED); atomic_init(&work->next_chunk, 0); atomic_init(&work->commit_chunk, 0); atomic_init(&work->max_chunk, (unsigned long)(chunk_count ? (chunk_count - 1) : 0)); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; atomic_init(&work->budget_returned, 0); work->budget_total = remote_taken; work->dbg_t0_ns = orpar_t0; atomic_init(&work->dbg_first_cut_chunk, (unsigned long)ULONG_MAX); for (ULO i = 0; i < chunk_count; i++) { const ULO start = (ULO)(((unsigned __int128)i * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); ULO end = (ULO)(((unsigned __int128)(i + 1) * (unsigned __int128)alt_count) / (unsigned __int128)chunk_count); if (end > alt_count) { end = alt_count; } chunks[i] = (pl_or_job){ .kind = PL_OR_JOB_WAMVM_SELECT1_RANGE, .prog = vm->prog, .q = vm->q, .goal = goal, .env_in = NULL, .wam_in = vm->st, .wamvm_code = g_wamvm_code, .wam_cont = rest_cont, .drop = NULL, .rest_goals = rest_goals, .rest_count = rest_count, .cut_barrier = (const void *)frame->cut_barrier, .exc_barrier = frame->exc_barrier, .depth = frame->depth, .stop_at_first = vm->stop_at_first, .capture_solution_output = (vm->out != NULL) || (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .capture_solution_spans = (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .on_solution = NULL, .on_solution_ctx = NULL, .wam_on_solution = g_wam_on_solution, .wam_on_solution_ctx = g_wam_on_solution_ctx, .on_solution_safe_temp_release = g_on_solution_safe_temp_release, .local_alloc_ok = true, .stringify_exceptions = false, .chunk_index = i, .work_done = NULL, .work_cancel = &work->cancel, }; atomic_init(&chunks[i].done, 0); chunks[i].u.select1_range.list0 = list0; chunks[i].u.select1_range.cons_functor = cons_functor; chunks[i].u.select1_range.start = start; chunks[i].u.select1_range.end = end; } for (ULO i = 0; i < worker_count; i++) { workers[i] = (pl_or_job){ .kind = PL_OR_JOB_WORKER, .prog = vm->prog, .work_done = &work->done, .work_cancel = &work->cancel, }; workers[i].u.worker.work = work; workers[i].budget_return = (i == 0) ? 0 : 1; atomic_init(&workers[i].done, 0); } pl_cut_signal ret = cut_none(); bool stopped = false; const ULO started = flowlog_start_or_work(work, 2, vm->rt_ctrl, vm->dbg_dat_ptr); if (g_par_budget && remote_taken && ((int)started < remote_taken)) { par_global_budget_give(g_par_budget, remote_taken - (int)started); remote_taken = (int)started; work->budget_total = remote_taken; } if (!work->unordered) { ULO last_done = 0; for (ULO i = 0; i < chunk_count; i++) { atomic_store(&work->commit_chunk, (unsigned long)i); pl_or_job *j = &chunks[i]; while (!atomic_load(&j->done)) { if (flowlog_cancelled()) { break; } // Help progress work while waiting for ordered chunk i to complete. unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], vm->rt_ctrl, vm->dbg_dat_ptr); continue; } usleep(1000); } pl_or_merge_output(vm->out, g_stdio_capture, vm->sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, vm->rt_ctrl, vm->dbg_dat_ptr); last_done = i + 1; if (stopped) { break; } } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); if (stopped && (last_done < chunk_count)) { for (ULO i = last_done; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], vm->rt_ctrl, vm->dbg_dat_ptr); } } } else { ULO done_count = 0; ULO scan = 0; pl_or_job *stop_job = NULL; while (done_count < chunk_count) { if (flowlog_cancelled()) { break; } bool progressed = false; for (ULO n = 0; n < chunk_count; n++) { const ULO idx = (scan + n) % chunk_count; pl_or_job *j = &chunks[idx]; const int done = atomic_load(&j->done); if (done != 1) { continue; } done_count++; scan = idx + 1; progressed = true; pl_or_merge_output(vm->out, g_stdio_capture, vm->sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } if (j->sig.cut) { ret = j->sig; stopped = true; stop_job = j; atomic_store(&work->cancel, 1); atomic_store(&j->done, 2); break; } pl_or_job_dispose(j, vm->rt_ctrl, vm->dbg_dat_ptr); atomic_store(&j->done, 2); } if (stopped) { break; } if (progressed) { continue; } if (atomic_load_explicit(&work->cancel, memory_order_relaxed)) { usleep(1000); continue; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], vm->rt_ctrl, vm->dbg_dat_ptr); continue; } usleep(1000); } if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); for (ULO i = 0; i < chunk_count; i++) { pl_or_job *j = &chunks[i]; if (j == stop_job) { continue; } if (atomic_load(&j->done) == 2) { continue; } pl_or_job_dispose(j, vm->rt_ctrl, vm->dbg_dat_ptr); } if (stop_job) { pl_or_job_dispose(stop_job, vm->rt_ctrl, vm->dbg_dat_ptr); } } flowlog_debug_orpar_log_stop(pred, pred_arity, alt_count, flowlog_monotonic_ns() - orpar_t0, stopped, atomic_load(&work->cancel) != 0); if (ret.except) { return ret; } if (ret.cut) { if (ret.target == &g_halt_barrier) { return ret; } // Commit the cut to the *outer* VM state (the inner VM used for chunks has its own CP stack). if (frame->cut_barrier) { wamvm_vm_cps_drop_to(vm, frame->cut_barrier->cp_base); if (vm->base_cut_barrier && (frame->cut_barrier == vm->base_cut_barrier)) { vm->cut_at_base = true; } } else { wamvm_vm_cps_drop_to(vm, 0); } } if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); // fail: select1/3 handled the continuation itself } if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } // Non-OR-par: keep select1/3 as a VM-native nondet goal so we avoid // building a continuation and re-entering the VM for each alternative. pl_term *prefix[256]; size_t prefix_count = 0; pl_term *cur = list0; ULO idx = 0; pl_list_cycle_guard cg; if (!has_cycle) { list_cycle_guard_init(&cg, cur); } while (1) { if (flowlog_cancelled()) { break; } if (has_cycle && (idx == cycle_end)) { idx = cycle_start; if (prefix_count > cycle_start) { prefix_count = cycle_start; } } cur = deref_term_wam(cur); if (!cur) { break; } if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { break; } pl_term *head = cur->v.str.args[0]; pl_term *tail = cur->v.str.args[1]; pl_term *rest = wamvm_vm_select1_build_rest(vm, cons_functor, (pl_term *const *)prefix, prefix_count, tail); if (unify_terms_wam(goal->v.str.args[0], head, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], rest, &vm->st->trail, vm->dbg_dat_ptr)) { pl_term *next = deref_term_wam(tail); const bool more = next && !term_is_nil(next); const ULO pc_after = frame->pc + 1; frame->pc = pc_after; if (more) { wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *cp = &vm->cps[vm->cp_count++]; memset(cp, 0, sizeof(*cp)); cp->kind = PL_WAMVM_CP_SELECT1; cp->frame_count = vm->frame_count; cp->frame_pc = pc_after; cp->frame_cut_barrier = frame->cut_barrier; cp->frame_exc_barrier = frame->exc_barrier; cp->frame_depth = frame->depth; cp->trail_mark = call_trail; cp->scope_mark = call_scope; cp->tmp_mark = outer_tm; cp->u.select1.goal = goal; cp->u.select1.list0 = list0; cp->u.select1.cons_functor = cons_functor; ULO next_idx = idx + 1; if (has_cycle && (next_idx == cycle_end)) { next_idx = cycle_start; } cp->u.select1.next_idx = next_idx; cp->u.select1.end_idx = (ULO)~(ULO)0; cp->u.select1.cycle_start = cycle_start; cp->u.select1.cycle_len = has_cycle ? cycle.cycle_len : 0; cp->u.select1.more = 1; wamvm_vm_cp_snapshot_capture(vm, cp); } if (out_ok) { *out_ok = 1; } return cut_none(); } // Restore to the select1/3 call entry state before trying the next element. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } if (prefix_count < (sizeof(prefix) / sizeof(prefix[0]))) { prefix[prefix_count++] = head; } else { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "select1", 3); } cur = tail; idx++; if (!has_cycle && list_cycle_guard_step_wam(&cg)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "select1", 3); } } // No alternative matched: restore and fail. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (release_temp) { temp_alloc_release(g_temp_alloc, outer_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return cut_none(); } if (!strcmp(fn, "length") && (ar == 2) && goal->v.str.args) { // Reuse the WAM-lite implementation's behavior (subset): this is enough for benchmarks. pl_term *list0 = deref_term_wam(goal->v.str.args[0]); pl_term *len0 = deref_term_wam(goal->v.str.args[1]); if (!list0 || !len0) { return cut_none(); } const bool list_is_var = (list0->tag == PL_TERM_VAR); const bool len_is_var = (len0->tag == PL_TERM_VAR); if (!len_is_var && (len0->tag != PL_TERM_INT)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", len0, &empty, "length", 2); } if (!len_is_var && (len0->v.int_value < 0)) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", len0, &empty, "length", 2); } // Fixed length: instantiate list when it is a variable. if (!len_is_var && list_is_var) { const SLO target = len0->v.int_value; if (target > (SLO)UINT32_MAX) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "length", 2); } pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); (void)wam_state_push_scope(vm->st, scope, (ULO)target, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *tail = make_nil_rt(vm->dbg_dat_ptr); for (SLO i = target; i > 0; i--) { pl_term *v = make_fresh_var_rt(vm->rt_ctrl, vm->dbg_dat_ptr, scope, (ULO)(i - 1)); pl_term *cons = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ".", 2); cons->v.str.args[0] = v; cons->v.str.args[1] = tail; tail = cons; } if (!unify_terms_wam(goal->v.str.args[0], tail, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Compute list length (List is nonvar) with N var (common benchmark mode). if (len_is_var && !list_is_var) { ULO n = 0; pl_term *cur = list0; for (;;) { cur = deref_term_wam(cur); if (!cur) { return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur)) { break; } if (term_is_pstr_nonempty(cur)) { ULO seg_len = 0; const pl_term *tail = NULL; if (!term_pstr_run_len_and_tail_peeled_const(cur, &seg_len, &tail)) { return cut_none(); } if (seg_len > (ULO)(LONG_MAX - (SLO)n)) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "length", 2); } n += seg_len; cur = (pl_term *)(tail ? tail : make_nil_rt(vm->dbg_dat_ptr)); continue; } if (cur->tag == PL_TERM_VAR) { // Close open tails to [] (ISO behavior for length/2 when N is a variable). pl_term *nil = make_nil_rt(vm->dbg_dat_ptr); if (!unify_terms_wam(cur, nil, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } break; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", list0, &empty, "length", 2); } if (n == (ULO)LONG_MAX) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "length", 2); } n++; cur = cur->v.str.args[1]; } pl_term *rhs = make_int_rt(vm->rt_ctrl, vm->dbg_dat_ptr, (SLO)n); if (!unify_terms_wam(goal->v.str.args[1], rhs, &vm->st->trail, vm->dbg_dat_ptr)) { return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Verify/constrain a nonvar list to a fixed length. if (!len_is_var && !list_is_var) { const SLO target = len0->v.int_value; if (target > (SLO)UINT32_MAX) { return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "length", 2); } const ULO mark = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; ULO n = 0; pl_term *cur = list0; for (;;) { cur = deref_term_wam(cur); if (!cur) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return cut_none(); } cur = (pl_term *)term_peel_pstr_empty_const(cur); if (term_is_nil(cur)) { break; } if (term_is_pstr_nonempty(cur)) { ULO seg_len = 0; const pl_term *tail = NULL; if (!term_pstr_run_len_and_tail_peeled_const(cur, &seg_len, &tail)) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return cut_none(); } if (seg_len > (ULO)(LONG_MAX - (SLO)n)) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "length", 2); } n += seg_len; if ((SLO)n > target) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return cut_none(); } cur = (pl_term *)(tail ? tail : make_nil_rt(vm->dbg_dat_ptr)); continue; } if (cur->tag == PL_TERM_VAR) { const SLO rem = target - (SLO)n; if (rem < 0) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return cut_none(); } if (rem > (SLO)UINT32_MAX) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "length", 2); } pl_term *tail = make_nil_rt(vm->dbg_dat_ptr); if (rem > 0) { pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); (void)wam_state_push_scope(vm->st, scope, (ULO)rem, vm->rt_ctrl, vm->dbg_dat_ptr); for (SLO i = rem; i > 0; i--) { pl_term *v = make_fresh_var_rt(vm->rt_ctrl, vm->dbg_dat_ptr, scope, (ULO)(i - 1)); pl_term *cons = make_struct_rt(vm->rt_ctrl, vm->dbg_dat_ptr, ".", 2); cons->v.str.args[0] = v; cons->v.str.args[1] = tail; tail = cons; } } if (!unify_terms_wam(cur, tail, &vm->st->trail, vm->dbg_dat_ptr)) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return cut_none(); } n = (ULO)target; break; } if (!term_is_list_pair(cur)) { pl_env empty = {0}; wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "list", list0, &empty, "length", 2); } if (n == (ULO)LONG_MAX) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return throw_representation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "term", "length", 2); } n++; if ((SLO)n > target) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return cut_none(); } cur = cur->v.str.args[1]; } if ((SLO)n != target) { wam_trail_unwind(&vm->st->trail, mark); vm->st->scope_count = mark_scope; return cut_none(); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } } } // Flowlog internal test helper: $flowlog_sleep_ms/1 (deterministic). if (goal->tag == PL_TERM_STRUCT && goal->v.str.args && goal->v.str.arity == 1 && goal->v.str.functor && !strcmp(goal->v.str.functor, "$flowlog_sleep_ms")) { pl_term *ms_t = deref_term_wam(goal->v.str.args[0]); if (!ms_t) { return cut_none(); } if (ms_t->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer"); } if (ms_t->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", ms_t, &empty, "$flowlog_sleep_ms", 1); } if (ms_t->v.int_value < 0) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", ms_t, &empty, "$flowlog_sleep_ms", 1); } // Keep it bounded to avoid absurd sleep values in case this is accidentally exposed. SLO ms = ms_t->v.int_value; if (ms > 600000) { ms = 600000; } usleep((useconds_t)((unsigned long)ms * 1000UL)); frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // Flowlog internal helpers: // - $flowlog_inference_limit/1: set per-thread inference cap // - $flowlog_inference_limit_shared/1: set shared cap across OR/AND-par threads if (goal->tag == PL_TERM_STRUCT && goal->v.str.args && goal->v.str.arity == 1 && goal->v.str.functor && (!strcmp(goal->v.str.functor, "$flowlog_inference_limit") || !strcmp(goal->v.str.functor, "$flowlog_inference_limit_shared"))) { const bool shared = !strcmp(goal->v.str.functor, "$flowlog_inference_limit_shared"); const CHR *pred_name = shared ? "$flowlog_inference_limit_shared" : "$flowlog_inference_limit"; pl_term *lim_t = deref_term_wam(goal->v.str.args[0]); if (!lim_t) { return cut_none(); } if (lim_t->tag == PL_TERM_VAR) { return throw_instantiation_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer"); } if (lim_t->tag != PL_TERM_INT) { pl_env empty = {0}; return throw_type_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "integer", lim_t, &empty, pred_name, 1); } if (lim_t->v.int_value < 0) { pl_env empty = {0}; return throw_domain_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "not_less_than_zero", lim_t, &empty, pred_name, 1); } if (shared) { flowlog_inference_limit_shared_set(g_par_state, (uint64_t)lim_t->v.int_value); } else { flowlog_inference_limit_local_set((uint64_t)lim_t->v.int_value); } frame->pc++; if (out_ok) { *out_ok = 1; } return cut_none(); } // User predicate call (bytecode). const CHR *pred_name = NULL; ULO pred_arity = 0; if (goal->tag == PL_TERM_ATOM) { pred_name = goal->v.atom_name; pred_arity = 0; } else if (goal->tag == PL_TERM_STRUCT) { pred_name = goal->v.str.functor; pred_arity = goal->v.str.arity; } bool pred_defined = false; if (pred_name && wamvm_vm_try_call_pred(vm, frame, goal, pred_name, pred_arity, tail_position, &pred_defined, vm->rt_ctrl, vm->dbg_dat_ptr)) { if (out_ok) { *out_ok = 1; } return cut_none(); } if (pred_defined) { if (vm->prog && vm->prog->flag_trace) { trace_emit_prolog_goal('!', frame->depth, "FAIL", goal, NULL); } return cut_none(); } // ISO-ish unknown procedure handling (prolog_flag unknown). if (vm->prog && pred_name) { if (vm->prog->flag_unknown == PL_UNKNOWN_FAIL || vm->prog->flag_unknown == PL_UNKNOWN_WARNING) { if (vm->prog->flag_trace) { trace_emit_prolog_goal('!', frame->depth, "FAIL", goal, NULL); } return cut_none(); } pl_env empty = {0}; pl_term *pi = make_pred_indicator_rt(vm->rt_ctrl, vm->dbg_dat_ptr, pred_name, pred_arity); return throw_existence_error(frame->exc_barrier, vm->rt_ctrl, vm->dbg_dat_ptr, "procedure", pi, &empty, pred_name, pred_arity); } // Unknown/unsupported goal: fail (program_supported should have prevented unsupported built-ins from reaching this point). return cut_none(); } static bool wamvm_vm_resume_pred(pl_wamvm_vm *vm, const pl_wamvm_choicepoint *cp) { if (!vm || !cp || cp->kind != PL_WAMVM_CP_PRED_CLAUSE) { return false; } const pl_wamvm_pred_code *pred = cp->u.pred.pred; pl_term *call_goal = cp->u.pred.call_goal; const pl_wamvm_barrier *call_bar = cp->u.pred.call_barrier; if (!pred || !call_goal) { return false; } if (vm->prog && vm->prog->flag_trace && cp->u.pred.had_exit) { trace_emit_prolog_goal('^', cp->frame_depth, "REDO", call_goal, NULL); } unsigned char matchable_local[PL_WAMVM_MATCHABLE_MAX]; unsigned char *matchable = NULL; const uint16_t match_mask = pred->matchable_arg_mask; if (match_mask && pred->clause_count && (pred->clause_count <= (ULO)PL_WAMVM_MATCHABLE_MAX)) { matchable = matchable_local; pl_term *gargs_local[PL_WAMVM_MATCHABLE_ARITY_MAX]; pl_term **gargs = NULL; ULO gargs_arity = 0; if (call_goal->tag == PL_TERM_STRUCT && call_goal->v.str.args) { const ULO ar = call_goal->v.str.arity; if (ar <= (ULO)PL_WAMVM_MATCHABLE_ARITY_MAX) { gargs = (pl_term **)gargs_local; gargs_arity = ar; for (ULO ai = 0; ai < ar; ai++) { gargs[ai] = (match_mask & (uint16_t)(1u << ai)) ? deref_term_wam(call_goal->v.str.args[ai]) : NULL; } } else { matchable = NULL; } } else { matchable = NULL; } if (!matchable) { // fall through with matchable disabled } else for (ULO mi = 0; mi < pred->clause_count; mi++) { matchable[mi] = 1; const pl_clause *mcl = pred->clauses[mi].cl; if (!mcl || !mcl->head) { matchable[mi] = 0; continue; } if (call_goal->tag == PL_TERM_STRUCT && mcl->head->tag == PL_TERM_STRUCT && call_goal->v.str.args && mcl->head->v.str.args) { const ULO ar = call_goal->v.str.arity; if (ar != mcl->head->v.str.arity) { matchable[mi] = 0; continue; } if (gargs && gargs_arity != ar) { gargs = NULL; gargs_arity = 0; } for (ULO ai = 0; ai < ar; ai++) { if (!(match_mask & (uint16_t)(1u << ai))) { continue; } const pl_term *harg = mcl->head->v.str.args[ai]; if (!harg) { continue; } if (harg->tag == PL_TERM_VAR && harg->v.var.scope == mcl->scope) { continue; } pl_term *garg = gargs ? gargs[ai] : (call_goal->v.str.args ? deref_term_wam(call_goal->v.str.args[ai]) : NULL); if (!garg || garg->tag == PL_TERM_VAR) { continue; } if (harg->tag == PL_TERM_ATOM) { if (garg->tag != PL_TERM_ATOM) { matchable[mi] = 0; break; } const CHR *gname = garg->v.atom_name; const CHR *hname = harg->v.atom_name; if ((gname != hname) && (!gname || !hname || strcmp(gname, hname))) { matchable[mi] = 0; break; } continue; } if (harg->tag == PL_TERM_INT) { if (garg->tag != PL_TERM_INT || garg->v.int_value != harg->v.int_value) { matchable[mi] = 0; break; } continue; } if (harg->tag == PL_TERM_FLOAT) { if (garg->tag != PL_TERM_FLOAT || garg->v.float_value != harg->v.float_value) { matchable[mi] = 0; break; } continue; } if (harg->tag == PL_TERM_STRUCT) { if (garg->tag != PL_TERM_STRUCT || garg->v.str.arity != harg->v.str.arity) { matchable[mi] = 0; break; } const CHR *gfn = garg->v.str.functor; const CHR *hfn = harg->v.str.functor; if ((gfn != hfn) && (!gfn || !hfn || strcmp(gfn, hfn))) { matchable[mi] = 0; break; } continue; } } } } } // Restore already done by caller: state is at cp->trail_mark/cp->scope_mark/cp->tmp_mark. for (ULO ci = cp->u.pred.next_ci; ci < pred->clause_count; ci++) { const pl_wamvm_clause_code *cc = &pred->clauses[ci]; const pl_clause *cl = cc ? cc->cl : NULL; if (!cl || !cl->head) { continue; } if (matchable && !matchable[ci]) { continue; } pl_scope *scope = NULL; pl_wam_cell *cells = NULL; pl_term *vars = NULL; if (!wamvm_alloc_scope_cells_vars(vm->st, cl->var_count, &scope, &cells, &vars, vm->rt_ctrl, vm->dbg_dat_ptr)) { continue; } pl_term_arena arena = clause_arena_alloc(cl, vm->rt_ctrl, vm->dbg_dat_ptr); wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &vm->st->trail, vm->rt_ctrl, vm->dbg_dat_ptr); if (!wamvm_unify_against_clause_term(call_goal, cl->head, cl->scope, vars, cl->var_count, &vm->st->trail, &arena, vm->dbg_dat_ptr, 0)) { // Restore to call entry marks (the caller already did; we must undo this attempt only). wam_trail_unwind(&vm->st->trail, cp->trail_mark); vm->st->scope_count = cp->scope_mark; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, cp->tmp_mark, vm->rt_ctrl, vm->dbg_dat_ptr); } continue; } // If there are more clauses after this one, push an updated choicepoint. bool need_cp = false; if (ci + 1 < pred->clause_count) { if (!matchable) { need_cp = true; } else { for (ULO mi = ci + 1; mi < pred->clause_count; mi++) { if (matchable[mi]) { need_cp = true; break; } } } } if (need_cp || (vm->prog && vm->prog->flag_trace)) { wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *ncp = &vm->cps[vm->cp_count++]; ncp->kind = PL_WAMVM_CP_PRED_CLAUSE; ncp->frame_count = cp->frame_count; ncp->frame_pc = cp->frame_pc; ncp->frame_cut_barrier = cp->frame_cut_barrier; ncp->frame_exc_barrier = cp->frame_exc_barrier; ncp->frame_depth = cp->frame_depth; ncp->trail_mark = cp->trail_mark; ncp->scope_mark = cp->scope_mark; ncp->tmp_mark = cp->tmp_mark; ncp->u.pred.call_goal = call_goal; ncp->u.pred.pred = pred; ncp->u.pred.next_ci = ci + 1; ncp->u.pred.call_barrier = call_bar; ncp->u.pred.had_exit = cp->u.pred.had_exit; wamvm_vm_cp_snapshot_capture(vm, ncp); } // Push clause frame (continuation frame already restored on stack by caller). wamvm_vm_vec_reserve_frames(vm, vm->frame_count + 1); pl_wamvm_frame *nf = &vm->frames[vm->frame_count++]; nf->kind = PL_WAMVM_FRAME_CLAUSE; nf->depth = cp->frame_depth + 1; nf->cut_barrier = call_bar; nf->exc_barrier = cp->frame_exc_barrier; nf->pc = 0; pl_term **inst = NULL; ULO inst_cap = 0; pl_wamvm_clause_frame *cf = NULL; if (cc && (cc->insn_count > 1)) { const ULO n = cc->insn_count; cf = (pl_wamvm_clause_frame *)pool_alloc(vm->rt_ctrl, (ULO)(sizeof(*cf) + (size_t)n * sizeof(*inst)), vm->dbg_dat_ptr); inst = (pl_term **)(cf + 1); inst_cap = n; memset(inst, 0, sizeof(*inst) * n); } else { cf = (pl_wamvm_clause_frame *)pool_alloc(vm->rt_ctrl, sizeof(*cf), vm->dbg_dat_ptr); } *cf = (pl_wamvm_clause_frame){ .code = cc, .cl = cl, .call_goal = call_goal, .scope = scope, .arena = arena, .vars = vars, .var_count = cl->var_count, .inst = inst, .inst_cap = inst_cap, }; nf->u.clause.cf = cf; return true; } return false; } static bool wamvm_vm_resume_retract(pl_wamvm_vm *vm, const pl_wamvm_choicepoint *cp) { if (!vm || !cp || cp->kind != PL_WAMVM_CP_RETRACT) { return false; } if (!vm->prog || !vm->st) { return false; } const CHR *target_name = cp->u.retract.target_name; const ULO target_arity = cp->u.retract.target_arity; pl_term *pat0 = cp->u.retract.pattern; if (!target_name || !pat0) { return false; } pl_term *pat = deref_term_wam(pat0); if (!pat) { return false; } pl_term *pat_head = pat; pl_term *pat_body = NULL; const bool pat_is_rule = pat->tag == PL_TERM_STRUCT && pat->v.str.arity == 2 && !strcmp(pat->v.str.functor, ":-"); if (pat_is_rule) { if (!pat->v.str.args) { return false; } pat_head = deref_term_wam(pat->v.str.args[0]); pat_body = deref_term_wam(pat->v.str.args[1]); } if (!pat_head) { return false; } const ULO call_trail = cp->trail_mark; const ULO call_scope = cp->scope_mark; const pl_temp_mark call_tm = cp->tmp_mark; for (ULO i = cp->u.retract.next_i; i <= cp->u.retract.snap_count; i++) { // Ensure we are at the call entry state for this attempt. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, call_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } pl_clause *cl = NULL; prog_db_rlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { cl = vm->prog->clauses[i]; } prog_db_runlock(vm->prog); if (!cl || !cl->head) { continue; } const pl_term *h0 = cl->head; const CHR *h_name = NULL; ULO h_arity = 0; if (h0->tag == PL_TERM_ATOM) { h_name = h0->v.atom_name; h_arity = 0; } else if (h0->tag == PL_TERM_STRUCT) { h_name = h0->v.str.functor; h_arity = h0->v.str.arity; } else { continue; } if (!h_name || strcmp(h_name, target_name) || (h_arity != target_arity)) { continue; } // ISO: retract(Head) matches only facts (Body=true). if (!pat_is_rule && cl->body_count) { continue; } pl_scope *scope = (pl_scope *)pool_alloc(vm->rt_ctrl, sizeof(*scope), vm->dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_wam_cell *cells = wam_state_push_scope(vm->st, scope, cl->var_count, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, vm->rt_ctrl, vm->dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, vm->dbg_dat_ptr, 0); pl_term *body_term = NULL; if (pat_is_rule) { pl_term **body_goals = NULL; if (cl->body_count) { body_goals = (pl_term **)pool_alloc(vm->rt_ctrl, sizeof(pl_term *) * cl->body_count, vm->dbg_dat_ptr); for (ULO bi = 0; bi < cl->body_count; bi++) { body_goals[bi] = clone_term_with_scope_arena(cl->body[bi + 1], cl->scope, scope, &arena, vm->dbg_dat_ptr, 0); } } body_term = build_conjunction_rt(vm->rt_ctrl, vm->dbg_dat_ptr, body_goals, cl->body_count); body_term = wrap_var_goals_rt(body_term, vm->rt_ctrl, vm->dbg_dat_ptr, 0); } wam_apply_clause_bindings_arena(cl, scope, &arena, cells, cl->var_count, &vm->st->trail, vm->rt_ctrl, vm->dbg_dat_ptr); bool ok = false; if (pat_is_rule) { ok = unify_terms_wam(pat_head, head, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(pat_body, body_term, &vm->st->trail, vm->dbg_dat_ptr); } else { ok = unify_terms_wam(pat_head, head, &vm->st->trail, vm->dbg_dat_ptr); } if (!ok) { continue; } // Permanent side-effect: once a clause is retracted, it stays retracted even if we backtrack. prog_db_wlock(vm->prog); if (vm->prog->clauses && (i <= vm->prog->clause_count)) { vm->prog->clauses[i] = NULL; } prog_index_invalidate(vm->prog); prog_db_wunlock(vm->prog); // If there are more candidate slots after this one, push an updated choicepoint. if (i + 1 <= cp->u.retract.snap_count) { wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); pl_wamvm_choicepoint *ncp = &vm->cps[vm->cp_count++]; memset(ncp, 0, sizeof(*ncp)); ncp->kind = PL_WAMVM_CP_RETRACT; ncp->frame_count = cp->frame_count; ncp->frame_pc = cp->frame_pc; ncp->frame_cut_barrier = cp->frame_cut_barrier; ncp->frame_exc_barrier = cp->frame_exc_barrier; ncp->frame_depth = cp->frame_depth; ncp->trail_mark = cp->trail_mark; ncp->scope_mark = cp->scope_mark; ncp->tmp_mark = cp->tmp_mark; ncp->u.retract.target_name = target_name; ncp->u.retract.target_arity = target_arity; ncp->u.retract.pattern = pat0; ncp->u.retract.next_i = i + 1; ncp->u.retract.snap_count = cp->u.retract.snap_count; wamvm_vm_cp_snapshot_capture(vm, ncp); } return true; } // No match: restore call entry state and continue backtracking. wam_trail_unwind(&vm->st->trail, call_trail); vm->st->scope_count = call_scope; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, call_tm, vm->rt_ctrl, vm->dbg_dat_ptr); } return false; } static bool wamvm_vm_resume_select1(pl_wamvm_vm *vm, pl_wamvm_choicepoint *cp) { if (!vm || !cp || cp->kind != PL_WAMVM_CP_SELECT1) { return false; } if (!vm->st) { return false; } pl_term *goal0 = cp->u.select1.goal; pl_term *list0 = cp->u.select1.list0; if (!goal0 || !list0) { return false; } pl_term *goal = deref_term_wam(goal0); if (!goal) { return false; } if (goal->tag != PL_TERM_STRUCT || !goal->v.str.args) { return false; } if (goal->v.str.arity != 3 && goal->v.str.arity != 5) { return false; } const CHR *cons_functor = cp->u.select1.cons_functor; const ULO end_idx = cp->u.select1.end_idx; const ULO cycle_start = cp->u.select1.cycle_start; const ULO cycle_len = cp->u.select1.cycle_len; const bool has_cycle = cycle_len > 0; const ULO cycle_end = has_cycle ? (cycle_start + cycle_len) : 0; ULO start_idx = cp->u.select1.next_idx; if (has_cycle && (start_idx >= cycle_end)) { start_idx = cycle_start; } const bool bounded = (end_idx != (ULO)~(ULO)0); if (bounded && (start_idx >= end_idx)) { return false; } pl_term *prefix[256]; size_t prefix_count = 0; pl_term *cur = list0; ULO idx = 0; pl_list_cycle_guard cg; if (!has_cycle) { list_cycle_guard_init(&cg, cur); } while (1) { if (flowlog_cancelled()) { return false; } if (has_cycle && (idx == cycle_end)) { idx = cycle_start; if (prefix_count > cycle_start) { prefix_count = cycle_start; } } cur = deref_term_wam(cur); if (!cur) { return false; } if (term_is_nil(cur)) { return false; } if (!term_is_list_pair(cur)) { return false; } pl_term *head = cur->v.str.args[0]; pl_term *tail = cur->v.str.args[1]; if (idx < start_idx) { if (prefix_count < (sizeof(prefix) / sizeof(prefix[0]))) { prefix[prefix_count++] = head; } else { return false; } cur = tail; idx++; if (!has_cycle && list_cycle_guard_step_wam(&cg)) { return false; } continue; } if (bounded && (idx >= end_idx)) { return false; } pl_term *rest = wamvm_vm_select1_build_rest(vm, cons_functor, prefix, prefix_count, tail); if (unify_terms_wam(goal->v.str.args[0], head, &vm->st->trail, vm->dbg_dat_ptr) && unify_terms_wam(goal->v.str.args[2], rest, &vm->st->trail, vm->dbg_dat_ptr)) { ULO next_idx = idx + 1; if (has_cycle && (next_idx == cycle_end)) { next_idx = cycle_start; } cp->u.select1.next_idx = next_idx; bool more = false; if (!bounded || (cp->u.select1.next_idx < end_idx)) { pl_term *next = deref_term_wam(tail); more = (next && !term_is_nil(next)); } cp->u.select1.more = more ? 1 : 0; return true; } // Restore to the select1/3 call entry state (the caller already did; we must undo this attempt only). wam_trail_unwind(&vm->st->trail, cp->trail_mark); vm->st->scope_count = cp->scope_mark; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, cp->tmp_mark, vm->rt_ctrl, vm->dbg_dat_ptr); } if (prefix_count < (sizeof(prefix) / sizeof(prefix[0]))) { prefix[prefix_count++] = head; } else { return false; } cur = tail; idx++; if (!has_cycle && list_cycle_guard_step_wam(&cg)) { return false; } } return false; } static bool wamvm_vm_backtrack(pl_wamvm_vm *vm) { if (!vm) { return false; } while (vm->cp_count) { pl_wamvm_choicepoint cp = vm->cps[--vm->cp_count]; // Restore WAM state. wam_trail_unwind(&vm->st->trail, cp.trail_mark); vm->st->scope_count = cp.scope_mark; if (vm->release_temp) { temp_alloc_release(g_temp_alloc, cp.tmp_mark, vm->rt_ctrl, vm->dbg_dat_ptr); } // Restore frame stack and the top frame's state. vm->frame_count = cp.frame_count; if (!vm->frame_count) { wamvm_vm_cp_snapshot_release(vm, &cp); continue; } (void)wamvm_vm_cp_snapshot_restore(vm, &cp); pl_wamvm_frame *top = &vm->frames[vm->frame_count - 1]; top->pc = cp.frame_pc; top->cut_barrier = cp.frame_cut_barrier; top->exc_barrier = cp.frame_exc_barrier; top->depth = cp.frame_depth; if (cp.kind == PL_WAMVM_CP_DISJ) { wamvm_vm_cp_snapshot_release(vm, &cp); wamvm_vm_push_frame_goal1(vm, cp.u.disj.g2, top->cut_barrier, top->exc_barrier, top->depth + 1); return true; } if (cp.kind == PL_WAMVM_CP_PRED_CLAUSE) { wamvm_vm_cp_snapshot_release(vm, &cp); if (wamvm_vm_resume_pred(vm, &cp)) { return true; } if (vm->prog && vm->prog->flag_trace) { trace_emit_prolog_goal('!', cp.frame_depth, "FAIL", cp.u.pred.call_goal, NULL); } // No clause matched; keep backtracking. continue; } if (cp.kind == PL_WAMVM_CP_RETRACT) { wamvm_vm_cp_snapshot_release(vm, &cp); if (wamvm_vm_resume_retract(vm, &cp)) { return true; } // No match; keep backtracking. continue; } if (cp.kind == PL_WAMVM_CP_REPEAT) { // repeat/0 choicepoint: re-arm it and resume after repeat/0. wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); vm->cps[vm->cp_count++] = cp; return true; } if (cp.kind == PL_WAMVM_CP_SELECT1) { if (wamvm_vm_resume_select1(vm, &cp)) { if (cp.u.select1.more) { // select1/3 choicepoint: re-arm it for remaining list elements. wamvm_vm_vec_reserve_cps(vm, vm->cp_count + 1); vm->cps[vm->cp_count++] = cp; } else { wamvm_vm_cp_snapshot_release(vm, &cp); } return true; } // No match: discard it and keep backtracking. wamvm_vm_cp_snapshot_release(vm, &cp); continue; } // Unhandled choicepoint kind: discard it and keep backtracking. wamvm_vm_cp_snapshot_release(vm, &cp); } return false; } static bool wamvm_vm_handle_exception(pl_wamvm_vm *vm, pl_cut_signal *sig) { if (!vm || !sig || !sig->except) { return false; } const void *target = sig->target; for (;;) { // Find the nearest catch/3 handler whose local exception barrier matches the throw target. SLO idx = -1; for (SLO i = (SLO)vm->cp_count - 1; i >= 0; i--) { const pl_wamvm_choicepoint *cp = &vm->cps[i]; if ((cp->kind == PL_WAMVM_CP_CATCH) && (cp->u.catch.local_exc == target)) { idx = i; break; } } if (idx < 0) { return false; } // Discard all choicepoints created after the catch/3 invocation. wamvm_vm_cps_drop_to(vm, (ULO)(idx + 1)); pl_wamvm_choicepoint *cp = &vm->cps[idx]; // Restore WAM state to the catch point. wam_trail_unwind(&vm->st->trail, cp->trail_mark); vm->st->scope_count = cp->scope_mark; // IMPORTANT: do not release query-temporary allocations here. // // The thrown exception term (and its environment) are allocated as part of the // current query's temporary arena. `catch/3` unifies the catcher with that // term, so freeing temp allocations up to the catch point would invalidate the // bound value and corrupt error reporting (notably in ISO conformance suites). // Restore VM frame stack to resume immediately after catch/3. vm->frame_count = cp->frame_count; if (!vm->frame_count) { return false; } (void)wamvm_vm_cp_snapshot_restore(vm, cp); pl_wamvm_frame *top = &vm->frames[vm->frame_count - 1]; top->pc = cp->frame_pc; top->cut_barrier = cp->frame_cut_barrier; top->exc_barrier = cp->frame_exc_barrier; top->depth = cp->frame_depth; // Try to unify the catcher with the exception term. If it doesn't match, // rethrow to the outer handler and keep searching. const ULO mark_trail = vm->st->trail.count; const ULO mark_scope = vm->st->scope_count; const pl_scope *exc_scope = term_find_first_scope_tr(sig->except_term, 0); if (exc_scope) { ULO max_var_id = 0; term_max_var_id_for_scope_tr(sig->except_term, exc_scope, &max_var_id, 0); env_max_var_id_for_scope_tr(sig->except_env, exc_scope, &max_var_id, 0); const ULO var_count = max_var_id + 1; pl_wam_cell *cells = wam_state_push_scope(vm->st, (pl_scope *)exc_scope, var_count, vm->rt_ctrl, vm->dbg_dat_ptr); if (cells && var_count) { wam_apply_env_bindings_to_cells(sig->except_env, exc_scope, cells, var_count); } } if (!unify_terms_wam(cp->u.catch.catcher, sig->except_term, &vm->st->trail, vm->dbg_dat_ptr)) { const void *outer = cp->u.catch.outer_exc; wam_trail_unwind(&vm->st->trail, mark_trail); vm->st->scope_count = mark_scope; // This catch/3 does not match; discard it and continue searching. wamvm_vm_cps_drop_to(vm, (ULO)idx); sig->target = outer; target = sig->target; continue; } // Caught: clear the exception and run the recovery goal before continuing. sig->except = false; sig->target = NULL; sig->except_term = NULL; sig->except_env = NULL; // Ensure recovery is invoked under the outer exception barrier and a call-local cut boundary. const pl_wamvm_barrier *cb = cp->u.catch.cut_barrier ? cp->u.catch.cut_barrier : top->cut_barrier; wamvm_vm_push_frame_goal1(vm, cp->u.catch.recover, cb, cp->u.catch.outer_exc, top->depth + 1); return true; } } static pl_cut_signal solve_goals_wamvm_cb(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_wam_cont *cont) { if (!st || !sol_count) { return cut_none(); } if (stop_at_first && *sol_count) { return cut_none(); } if (flowlog_cancelled()) { return cut_none(); } const bool reuse_scratch = (g_wamvm_vm_scratch_depth == 0); g_wamvm_vm_scratch_depth++; pl_wamvm_vm_scratch *scratch = reuse_scratch ? &g_wamvm_vm_scratch : NULL; pl_wamvm_vm vm; memset(&vm, 0, sizeof(vm)); vm.prog = prog; vm.q = q; vm.st = st; vm.stop_at_first = stop_at_first; vm.out = out; vm.sol_count = sol_count; vm.rt_ctrl = rt_ctrl; vm.dbg_dat_ptr = dbg_dat_ptr; vm.release_temp = (g_temp_alloc != NULL); if (scratch) { vm.frames = scratch->frames; vm.frame_cap = scratch->frame_cap; vm.cps = scratch->cps; vm.cp_cap = scratch->cp_cap; vm.frames_snap = scratch->frames_snap; vm.frames_snap_cap = scratch->frames_snap_cap; } pl_cut_signal ret = cut_none(); // Build the continuation frame chain (tail -> head), then push the base goals frame on top. const pl_wamvm_barrier *base_bar = (const pl_wamvm_barrier *)cut_barrier; const pl_wamvm_barrier fallback_bar = {.prev = NULL, .cp_base = 0}; if (!base_bar) { base_bar = &fallback_bar; } vm.base_cut_barrier = base_bar; vm.cut_at_base = false; // Collect cont nodes. const pl_wam_cont **cont_nodes = NULL; ULO cont_n = 0; ULO cont_cap = 0; for (const pl_wam_cont *c = cont; c; c = c->next) { if (cont_n == cont_cap) { ULO new_cap = cont_cap ? (cont_cap * 2) : 16; const pl_wam_cont **new_nodes = (const pl_wam_cont **)pool_alloc(rt_ctrl, sizeof(*new_nodes) * new_cap, dbg_dat_ptr); if (cont_nodes) { memcpy(new_nodes, cont_nodes, sizeof(*new_nodes) * cont_n); } cont_nodes = new_nodes; cont_cap = new_cap; } cont_nodes[cont_n++] = c; } // Push continuation frames from tail to head so the head runs immediately after the base list completes. ULO d = depth; for (ULO i = cont_n; i > 0; i--) { const pl_wam_cont *c = cont_nodes[i - 1]; if (!c) { continue; } d++; const pl_wamvm_barrier *cb = (const pl_wamvm_barrier *)c->cut_barrier; if (!cb) { cb = base_bar; } wamvm_vm_push_frame_goals(&vm, c->goals, c->goal_count, cb, exc_barrier, d); } wamvm_vm_push_frame_goals(&vm, goals, goal_count, base_bar, exc_barrier, depth); for (;;) { if (stop_at_first && *sol_count) { break; } { const void *lim_barrier = exc_barrier; if (vm.frame_count) { lim_barrier = vm.frames[vm.frame_count - 1].exc_barrier; } pl_cut_signal lim = flowlog_inference_limit_tick(lim_barrier, rt_ctrl, dbg_dat_ptr); if (lim.except) { if (wamvm_vm_handle_exception(&vm, &lim)) { continue; } ret = lim; goto done; } } if (flowlog_cancelled()) { break; } if (!vm.frame_count) { // Solved all frames: emit solution and backtrack. if (g_wam_on_solution) { on_solution_lock(); g_wam_on_solution(st, g_wam_on_solution_ctx, rt_ctrl, dbg_dat_ptr); on_solution_unlock(); } if (out) { if (g_solution_capture && g_solution_capture->out == out) { const size_t start = out->len; env_to_sbuf_wam(q, st->q_cells, out, dbg_dat_ptr); (void)solution_capture_mark(out, start); } else { if (*sol_count) { sbuf_append_cstr(out, "\n; "); } else { sbuf_append_cstr(out, " "); } env_to_sbuf_wam(q, st->q_cells, out, dbg_dat_ptr); } } (*sol_count)++; if (stop_at_first && *sol_count) { break; } if (!wamvm_vm_backtrack(&vm)) { break; } continue; } pl_wamvm_frame *f = &vm.frames[vm.frame_count - 1]; if (!f) { vm.frame_count--; continue; } if (f->kind == PL_WAMVM_FRAME_GOAL1) { if (f->pc >= 1) { vm.frame_count--; continue; } int ok = 0; const pl_clause *saved_argv_clause = flowlog_argv_clause_push(NULL); pl_cut_signal sig = wamvm_vm_exec_goal(&vm, f, f->u.goal1.goal, true, &ok); flowlog_argv_clause_pop(saved_argv_clause); if (sig.cut) { ret = sig; goto done; } if (sig.except) { if (wamvm_vm_handle_exception(&vm, &sig)) { continue; } ret = sig; goto done; } if (!ok) { if (!wamvm_vm_backtrack(&vm)) { break; } continue; } continue; } if (f->kind == PL_WAMVM_FRAME_GOALS) { if (f->pc >= f->u.goals.goal_count) { vm.frame_count--; continue; } pl_term *raw_goal = f->u.goals.goals ? f->u.goals.goals[f->pc] : NULL; if (!raw_goal) { if (!wamvm_vm_backtrack(&vm)) { break; } continue; } int ok = 0; const bool tail_pos = (f->pc + 1 >= f->u.goals.goal_count); const pl_clause *saved_argv_clause = flowlog_argv_clause_push(NULL); pl_cut_signal sig = wamvm_vm_exec_goal(&vm, f, raw_goal, tail_pos, &ok); flowlog_argv_clause_pop(saved_argv_clause); if (sig.cut) { ret = sig; goto done; } if (sig.except) { if (wamvm_vm_handle_exception(&vm, &sig)) { continue; } ret = sig; goto done; } if (!ok) { if (!wamvm_vm_backtrack(&vm)) { break; } continue; } continue; } if (f->kind == PL_WAMVM_FRAME_CLAUSE) { pl_wamvm_clause_frame *cf = f->u.clause.cf; const pl_wamvm_clause_code *cc = cf ? cf->code : NULL; if (!cc || !cc->insn || !cc->insn_count) { vm.frame_count--; continue; } if (f->pc >= cc->insn_count) { vm.frame_count--; continue; } const pl_wamvm_insn *insn = &cc->insn[f->pc]; if (!insn) { if (!wamvm_vm_backtrack(&vm)) { break; } continue; } if (insn->op == PL_WAMVM_OP_PROCEED) { if (prog && prog->flag_trace && cf && cf->call_goal) { const ULO call_depth = (f->depth > 0) ? (f->depth - 1) : 0; trace_emit_prolog_goal('<', call_depth, "EXIT", cf->call_goal, cf->cl); wamvm_vm_mark_pred_choicepoint_exit(&vm, cf->call_goal); } vm.frame_count--; continue; } if (insn->op != PL_WAMVM_OP_CALL) { if (!wamvm_vm_backtrack(&vm)) { break; } continue; } pl_term *inst_goal = NULL; if (cf && cf->inst) { inst_goal = cf->inst[f->pc]; } if (!inst_goal) { inst_goal = wamvm_instantiate_term_arena(insn->goal, (cf && cf->cl) ? cf->cl->scope : NULL, cf ? cf->vars : NULL, cf ? cf->var_count : 0, cf ? &cf->arena : NULL, dbg_dat_ptr, 0); if (cf && cf->inst) { cf->inst[f->pc] = inst_goal; } } if (!inst_goal) { if (!wamvm_vm_backtrack(&vm)) { break; } continue; } int ok = 0; const bool tail_pos = (f->pc + 1 < cc->insn_count) && (cc->insn[f->pc + 1].op == PL_WAMVM_OP_PROCEED); const pl_clause *saved_argv_clause = flowlog_argv_clause_push(cf ? cf->cl : NULL); pl_cut_signal sig = wamvm_vm_exec_goal(&vm, f, inst_goal, tail_pos, &ok); flowlog_argv_clause_pop(saved_argv_clause); if (sig.cut) { ret = sig; goto done; } if (sig.except) { if (wamvm_vm_handle_exception(&vm, &sig)) { continue; } ret = sig; goto done; } if (!ok) { if (!wamvm_vm_backtrack(&vm)) { break; } continue; } continue; } // Unknown frame kind: drop it. vm.frame_count--; } // WAMVM VM cut propagation (for OR-par cancellation/meta-builtins): // if any `!/0` executed at the base cut barrier of this VM run, report it. if (vm.cut_at_base && (base_bar != &fallback_bar)) { ret = cut_to(base_bar); } else { ret = cut_none(); } done: if (scratch) { scratch->frames = vm.frames; scratch->frame_cap = vm.frame_cap; scratch->cps = vm.cps; scratch->cp_cap = vm.cp_cap; scratch->frames_snap = vm.frames_snap; scratch->frames_snap_cap = vm.frames_snap_cap; // Reset per-run counts so stale entries are never observed. vm.frame_count = 0; vm.cp_count = 0; vm.frames_snap_top = 0; } else { wamvm_vm_free(&vm); } g_wamvm_vm_scratch_depth--; return ret; } static bool flowlog_wamvm_require_vm_enabled(void) { const char *e = getenv("FLOWLOG_WAMVM_REQUIRE_VM"); if (!e || !*e) { return false; } return strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false"); } static bool flowlog_wamvm_profile_enabled(void) { const char *e = getenv("FLOWLOG_PROFILE_WAMVM"); if (!e || !*e) { return false; } return strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false"); } static pl_cut_signal solve_goals_wamvm(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, pl_wam_state *st, const void *cut_barrier, const void *exc_barrier, ULO depth, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_wam_state *saved = g_wam_state; const pl_wamvm_prog_code *saved_code = g_wamvm_code; const bool saved_used = g_wamvm_vm_used; const bool prof = flowlog_wamvm_profile_enabled(); if (prof) { if (g_wamvm_prof_nesting++ == 0) { g_wamvm_prof_snap_captures = 0; g_wamvm_prof_snap_capture_frames = 0; g_wamvm_prof_snap_restores = 0; g_wamvm_prof_snap_restore_frames = 0; g_wamvm_prof_pred_calls = 0; g_wamvm_prof_clause_attempts = 0; g_wamvm_prof_clause_matches = 0; g_wamvm_prof_pred_fail = 0; } } g_wam_state = st; g_wamvm_vm_used = false; pl_cut_signal r = cut_none(); if (!prog || !st || !sol_count) { goto out; } // Ensure the predicate index exists (needed for bytecode lookup and for fallback). prog_index_ensure(prog, rt_ctrl, dbg_dat_ptr); pl_wamvm_support_info sup = {0}; const bool supported = wamvm_vm_program_supported(prog, q, &sup); if (!supported) { if (flowlog_wamvm_require_vm_enabled()) { if (sup.goal_name && *sup.goal_name) { (void)fprintf(stderr, "flowlog: error: WAMVM VM required, but program/query uses unsupported goal: %s/%lu (in %s/%lu)\n", sup.goal_name, (unsigned long)sup.goal_arity, sup.context_name ? sup.context_name : "", (unsigned long)sup.context_arity); } else { (void)fprintf(stderr, "flowlog: error: WAMVM VM required, but program/query uses unsupported built-ins\n"); } g_halt_requested = true; g_halt_code = 2; r = cut_to(&g_halt_barrier); goto out; } // Fall back to the existing WAM-lite solver. r = solve_goals_wam(prog, q, goals, goal_count, st, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); goto out; } if (!g_wamvm_code || (g_wamvm_code->prog != prog) || (g_wamvm_code->clause_epoch != atomic_load_explicit(&prog->clause_epoch, memory_order_acquire))) { g_wamvm_code = wamvm_program_code_build(prog, rt_ctrl, dbg_dat_ptr); } g_wamvm_vm_used = true; r = solve_goals_wamvm_cb(prog, q, goals, goal_count, st, cut_barrier, exc_barrier, depth, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr, NULL); out: g_wam_state = saved; g_wamvm_code = saved_code; g_wamvm_vm_used = saved_used; if (prof) { if (--g_wamvm_prof_nesting == 0) { const uint64_t sz = (uint64_t)sizeof(pl_wamvm_frame); (void)fprintf(stderr, "flowlog: wamvm profile: snapshots: capture=%llu (%llu frames, %llu bytes) restore=%llu (%llu frames, %llu bytes)\n" "flowlog: wamvm profile: calls: pred_calls=%llu clause_attempts=%llu clause_matches=%llu pred_fail=%llu\n", (unsigned long long)g_wamvm_prof_snap_captures, (unsigned long long)g_wamvm_prof_snap_capture_frames, (unsigned long long)(g_wamvm_prof_snap_capture_frames * sz), (unsigned long long)g_wamvm_prof_snap_restores, (unsigned long long)g_wamvm_prof_snap_restore_frames, (unsigned long long)(g_wamvm_prof_snap_restore_frames * sz), (unsigned long long)g_wamvm_prof_pred_calls, (unsigned long long)g_wamvm_prof_clause_attempts, (unsigned long long)g_wamvm_prof_clause_matches, (unsigned long long)g_wamvm_prof_pred_fail); } } return r; } /* ============================================================================ * SECTION 25: CLI Source Loading * consult/load helpers for CLI and REPL. * ============================================================================ */ /* --- SUBSECTION 25.1: Source Parsing Helpers ----------------------------- */ // Source parsing helpers and join builtin utilities. // flowlog_fatal_cannot_load_file() reports load errors; join_count_flatten_conj()/join_flatten_conj() normalize join inputs. static char *flowlog_resolve_program_path(const char *spec); static CHR *flowlog_read_entire_file(const char *path, size_t *out_len); static void parse_program_src_into( pl_program *prog, const CHR *src, const char *src_name, const void *rt_ctrl, const ULO *dbg_dat_ptr, int include_depth); static void flowlog_fatal_cannot_load_file(const char *path, const ULO *dbg_dat_ptr) { if (!path) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: cannot load: (null)", dbg_dat_ptr); } const size_t n = strlen(path); const size_t cap = n + 32; char *msg = (char *)malloc(cap); if (!msg) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } (void)snprintf(msg, cap, "flowlog: cannot load: %s", path); rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, msg, dbg_dat_ptr); } static void parse_program_consult_list(pl_program *prog, const pl_term *list, const void *rt_ctrl, const ULO *dbg_dat_ptr, int include_depth) { if (!prog || !list) { return; } if (include_depth > 64) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: consult nesting too deep", dbg_dat_ptr); } const pl_term *cur = list; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid consult directive list", dbg_dat_ptr); } const pl_term *h = cur->v.str.args[0]; if (!h || h->tag != PL_TERM_ATOM || !h->v.atom_name) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid consult directive file", dbg_dat_ptr); } char *rp = flowlog_resolve_program_path(h->v.atom_name); if (!rp) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t n = 0; CHR *src = flowlog_read_entire_file(rp, &n); if (!src) { flowlog_fatal_cannot_load_file(rp, dbg_dat_ptr); } parse_program_src_into(prog, src, rp, rt_ctrl, dbg_dat_ptr, include_depth + 1); free(src); free(rp); cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, NULL)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid consult directive list", dbg_dat_ptr); } } } static void parse_program_consult_spec(pl_program *prog, const pl_term *spec, const void *rt_ctrl, const ULO *dbg_dat_ptr, int include_depth) { if (!prog || !spec) { return; } if (include_depth > 64) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: consult nesting too deep", dbg_dat_ptr); } if (term_is_nil(spec) || term_is_list_pair(spec)) { parse_program_consult_list(prog, spec, rt_ctrl, dbg_dat_ptr, include_depth); return; } if (spec->tag != PL_TERM_ATOM || !spec->v.atom_name) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid consult directive file", dbg_dat_ptr); } char *rp = flowlog_resolve_program_path(spec->v.atom_name); if (!rp) { rise_error_info_dbg(ECODE_RT__FLOWLOG_OOM, "flowlog: out of memory", dbg_dat_ptr); } size_t n = 0; CHR *src = flowlog_read_entire_file(rp, &n); if (!src) { flowlog_fatal_cannot_load_file(rp, dbg_dat_ptr); } parse_program_src_into(prog, src, rp, rt_ctrl, dbg_dat_ptr, include_depth + 1); free(src); free(rp); } static void prog_init_goal_add( pl_program *prog, pl_term *goal, const pl_scope *scope, const pl_var_table *vt, const CHR *src_name, ULO src_line, ULO src_col, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !goal) { return; } if (!prog->init_goals) { ULO cap = prog->init_goal_cap ? prog->init_goal_cap : 4; prog->init_goals = (pl_init_goal **)pool_alloc(rt_ctrl, sizeof(pl_init_goal *) * (cap + 1), dbg_dat_ptr); memset(prog->init_goals, 0, sizeof(pl_init_goal *) * (cap + 1)); prog->init_goal_cap = cap; prog->init_goal_count = 0; } if (prog->init_goal_count == prog->init_goal_cap) { ULO new_cap = prog->init_goal_cap ? (prog->init_goal_cap * 2) : 4; pl_init_goal **new_items = (pl_init_goal **)pool_alloc(rt_ctrl, sizeof(pl_init_goal *) * (new_cap + 1), dbg_dat_ptr); memset(new_items, 0, sizeof(pl_init_goal *) * (new_cap + 1)); for (ULO i = 1; i <= prog->init_goal_count; i++) { new_items[i] = prog->init_goals[i]; } prog->init_goals = new_items; prog->init_goal_cap = new_cap; } pl_init_goal *ig = (pl_init_goal *)pool_alloc(rt_ctrl, sizeof(*ig), dbg_dat_ptr); memset(ig, 0, sizeof(*ig)); ig->goal = goal; ig->scope = scope; ig->var_count = vt ? vt->count : 0; ig->var_names = (vt && vt->count) ? vt->names : NULL; ig->src_name = (src_name && *src_name) ? pool_strdup(rt_ctrl, src_name, dbg_dat_ptr) : NULL; ig->src_line = src_line; ig->src_col = src_col; prog->init_goal_count++; prog->init_goals[prog->init_goal_count] = ig; } static pl_program *parse_program_src(const void *rt_ctrl, const ULO *dbg_dat_ptr, const CHR *src, const char *src_name) { if (!src) { return NULL; } pl_program *prog = (pl_program *)pool_alloc(rt_ctrl, sizeof(*prog), dbg_dat_ptr); memset(prog, 0, sizeof(*prog)); prog->op_overrides = op_overrides_create(rt_ctrl, dbg_dat_ptr); prog->flag_unknown = PL_UNKNOWN_ERROR; prog->flag_char_conversion = false; for (ULO i = 0; i < 256; i++) { prog->char_conv_table[i] = (unsigned char)i; } prog->flag_character_escapes = true; prog->flag_occurs_check = false; prog->flag_debug = false; prog->flag_trace = false; prog->flag_itrace = false; prog->flag_itrace_watermark = false; prog->flag_double_quotes = PL_DQ_CHARS; // Default execution mode: maximize throughput for unmodified ISO programs. // - Prefer the WAMVM engine (falls back to WAM-lite when unsupported features are used, e.g. tabling). // - Enable the "fast" parallel profile (unordered OR-par + AND-par) by default. prog->flag_engine = PL_ENGINE_WAMVM; prog->flag_parallel_or = true; prog->flag_parallel_or_order = PL_OR_UNORDERED; prog->flag_parallel_and = true; prog->flag_parallel_max_depth = flowlog_default_parallel_max_depth_auto(); { // Scale default nesting on high-core systems so deep nondet search can // use more CPUs than the top-level branching factor. SLO nest = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST; const ULO ncpu = get_n_cpuproc(); if (ncpu >= 128) { nest = 8; } else if (ncpu >= 64) { nest = 4; } else if (ncpu >= 32) { nest = 2; } prog->flag_parallel_or_nesting = nest; } atomic_init(&prog->clause_epoch, 1); atomic_init(&prog->index_epoch, 0); atomic_init(&prog->db_readers, 0); atomic_init(&prog->db_writer, 0); prog->pred_index = NULL; ULO facts_cap = 8; prog->facts = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * (facts_cap + 1), dbg_dat_ptr); prog->facts[0] = NULL; prog->fact_count = 0; prog->fact_cap = facts_cap; ULO clauses_cap = 8; prog->clauses = (pl_clause **)pool_alloc(rt_ctrl, sizeof(pl_clause *) * (clauses_cap + 1), dbg_dat_ptr); prog->clauses[0] = NULL; prog->clause_count = 0; prog->clause_cap = clauses_cap; ULO init_cap = 4; prog->init_goals = (pl_init_goal **)pool_alloc(rt_ctrl, sizeof(pl_init_goal *) * (init_cap + 1), dbg_dat_ptr); memset(prog->init_goals, 0, sizeof(pl_init_goal *) * (init_cap + 1)); prog->init_goal_count = 0; prog->init_goal_cap = init_cap; parse_program_src_into(prog, src, src_name, rt_ctrl, dbg_dat_ptr, 0); prog->wam_requires_interp = program_requires_interp_for_wam(prog); prog_index_build_locked(prog, rt_ctrl, dbg_dat_ptr); atomic_store_explicit( &prog->index_epoch, atomic_load_explicit(&prog->clause_epoch, memory_order_acquire), memory_order_release); return prog; } static void parse_program_src_into( pl_program *prog, const CHR *src, const char *src_name, const void *rt_ctrl, const ULO *dbg_dat_ptr, int include_depth) { if (!prog || !src) { return; } ULO facts_cap = prog->fact_cap ? prog->fact_cap : 8; ULO clauses_cap = prog->clause_cap ? prog->clause_cap : 8; pl_parse p = {0}; p.src_name = src_name; p.rt_ctrl = rt_ctrl; p.dbg_dat_ptr = dbg_dat_ptr; p.ops = prog->op_overrides; p.double_quotes = prog->flag_double_quotes; p.character_escapes = prog->flag_character_escapes; lex_init(&p.lx, src, false, NULL, prog->flag_character_escapes); const CHR *clause_src_name = NULL; if (src_name && *src_name) { clause_src_name = pool_strdup(rt_ctrl, src_name, dbg_dat_ptr); } for (;;) { pl_tok tk = peek_tok(&p); if (tk.type == TOK_EOF) { break; } // Support directives of the form ':- Goal.' (e.g. ':- op(500, xfy, foo).'). // These are executed at load time and are not stored as clauses. if (tk.type == TOK_COLON_DASH) { ULO dir_line = 0; ULO dir_col = 0; compute_line_col(src, tk.start, &dir_line, &dir_col); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_var_table vt = {0}; pl_term *dir = parse_term(&p, &vt, scope, true, 1200); expect_tok(&p, TOK_DOT); // Handle a small subset of common directives at load time (op/3, // dynamic/1, table/1, and a whitelist of set_prolog_flag/2). Unknown // directives are ignored to keep parsing permissive. if (dir && dir->tag == PL_TERM_STRUCT && dir->v.str.arity == 1 && !strcmp(dir->v.str.functor, ":-")) { pl_term *g = dir->v.str.args[0]; // ISO consult directive: `:- consult(File).` or `:- consult([File1, ...]).` if (g && g->tag == PL_TERM_STRUCT && g->v.str.functor && g->v.str.args && (g->v.str.arity == 1) && !strcmp(g->v.str.functor, "consult")) { parse_program_consult_spec(prog, g->v.str.args[0], rt_ctrl, dbg_dat_ptr, include_depth); continue; } // ISO-ish: `:- initialization(Goal).` (collected and executed after load). if (g && g->tag == PL_TERM_STRUCT && g->v.str.functor && g->v.str.args && (g->v.str.arity == 1) && !strcmp(g->v.str.functor, "initialization")) { prog_init_goal_add(prog, g->v.str.args[0], scope, &vt, src_name, dir_line, dir_col, rt_ctrl, dbg_dat_ptr); continue; } if (g && g->tag == PL_TERM_STRUCT && g->v.str.arity == 3 && !strcmp(g->v.str.functor, "op")) { // Execute op/3 at load time. // Errors are treated as parse errors during program load. // (Full ISO directive semantics will expand over time.) pl_term *prec_term = g->v.str.args[0]; pl_term *spec_term = g->v.str.args[1]; pl_term *ops_term = g->v.str.args[2]; if (!prec_term || prec_term->tag != PL_TERM_INT) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive precedence", dbg_dat_ptr); } const SLO prec = prec_term->v.int_value; if (prec < 0 || prec > 1200) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive precedence", dbg_dat_ptr); } if (!spec_term || spec_term->tag != PL_TERM_ATOM) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive specifier", dbg_dat_ptr); } pl_op_fix fix = PL_OP_INFIX_XFX; if (!strcmp(spec_term->v.atom_name, "xfx")) { fix = PL_OP_INFIX_XFX; } else if (!strcmp(spec_term->v.atom_name, "xfy")) { fix = PL_OP_INFIX_XFY; } else if (!strcmp(spec_term->v.atom_name, "yfx")) { fix = PL_OP_INFIX_YFX; } else if (!strcmp(spec_term->v.atom_name, "fx")) { fix = PL_OP_PREFIX_FX; } else if (!strcmp(spec_term->v.atom_name, "fy")) { fix = PL_OP_PREFIX_FY; } else if (!strcmp(spec_term->v.atom_name, "xf")) { fix = PL_OP_POSTFIX_XF; } else if (!strcmp(spec_term->v.atom_name, "yf")) { fix = PL_OP_POSTFIX_YF; } else { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive specifier", dbg_dat_ptr); } if (!ops_term) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive operator", dbg_dat_ptr); } if (ops_term->tag == PL_TERM_ATOM) { (void)op_override_set(prog, ops_term->v.atom_name, fix, (int)prec, rt_ctrl, dbg_dat_ptr); } else if (term_is_list_pair(ops_term)) { pl_term *cur = ops_term; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive operator list", dbg_dat_ptr); } pl_term *h = cur->v.str.args[0]; if (!h || h->tag != PL_TERM_ATOM) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive operator list", dbg_dat_ptr); } (void)op_override_set(prog, h->v.atom_name, fix, (int)prec, rt_ctrl, dbg_dat_ptr); cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, NULL)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive operator list", dbg_dat_ptr); } } } else { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid op/3 directive operator", dbg_dat_ptr); } } // Common portability pattern (Scryer/SWI/etc): // :- catch(set_prolog_flag(flowlog_parallel_profile, fast), _, true). // Trealla ignores unknown directives, but Flowlog can still recognize this // shape and apply the inner set_prolog_flag/2 when it is whitelisted. if (g && g->tag == PL_TERM_STRUCT && g->v.str.arity == 3 && !strcmp(g->v.str.functor, "catch")) { pl_term *inner = g->v.str.args[0]; if (inner && inner->tag == PL_TERM_STRUCT && inner->v.str.arity == 2 && !strcmp(inner->v.str.functor, "set_prolog_flag")) { g = inner; } } if (g && g->tag == PL_TERM_STRUCT && g->v.str.arity == 2 && !strcmp(g->v.str.functor, "set_prolog_flag")) { // Execute a small whitelist of set_prolog_flag/2 at load time. // This keeps examples ergonomic (no need to prefix every query), while // still keeping directive parsing permissive for unknown flags. pl_term *flag = g->v.str.args[0]; pl_term *val = g->v.str.args[1]; if (flag && (flag->tag == PL_TERM_ATOM) && flag->v.atom_name && val) { const CHR *fname = flag->v.atom_name; if (!strcmp(fname, "flowlog_parallel")) { if (val->tag != PL_TERM_ATOM || !val->v.atom_name || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_parallel", dbg_dat_ptr); } const bool on = !strcmp(val->v.atom_name, "on"); prog->flag_parallel_or = on; prog->flag_parallel_and = on; } if (!strcmp(fname, "flowlog_parallel_profile")) { if (val->tag != PL_TERM_ATOM || !val->v.atom_name || (strcmp(val->v.atom_name, "off") && strcmp(val->v.atom_name, "iso") && strcmp(val->v.atom_name, "fast"))) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_parallel_profile", dbg_dat_ptr); } if (!strcmp(val->v.atom_name, "off")) { prog->flag_parallel_or = false; prog->flag_parallel_and = false; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else if (!strcmp(val->v.atom_name, "iso")) { prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else { // fast prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_UNORDERED; // Match runtime set_prolog_flag/2 behavior: scale nesting on // high-core systems so deep search can use more CPUs than the // top-level branching factor. SLO nest = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST; const ULO ncpu = get_n_cpuproc(); if (ncpu >= 128) { nest = 8; } else if (ncpu >= 64) { nest = 4; } else if (ncpu >= 32) { nest = 2; } prog->flag_parallel_or_nesting = nest; } } if (!strcmp(fname, "flowlog_parallel_or")) { if (val->tag != PL_TERM_ATOM || !val->v.atom_name || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_parallel_or", dbg_dat_ptr); } prog->flag_parallel_or = !strcmp(val->v.atom_name, "on"); } if (!strcmp(fname, "flowlog_parallel_or_order")) { if (val->tag != PL_TERM_ATOM || !val->v.atom_name || (strcmp(val->v.atom_name, "ordered") && strcmp(val->v.atom_name, "unordered"))) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_parallel_or_order", dbg_dat_ptr); } prog->flag_parallel_or_order = !strcmp(val->v.atom_name, "unordered") ? PL_OR_UNORDERED : PL_OR_ORDERED; } if (!strcmp(fname, "flowlog_parallel_and")) { if (val->tag != PL_TERM_ATOM || !val->v.atom_name || (strcmp(val->v.atom_name, "on") && strcmp(val->v.atom_name, "off"))) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_parallel_and", dbg_dat_ptr); } prog->flag_parallel_and = !strcmp(val->v.atom_name, "on"); } if (!strcmp(fname, "flowlog_parallel_max_depth")) { if (val->tag != PL_TERM_INT || val->v.int_value < 0) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_parallel_max_depth", dbg_dat_ptr); } prog->flag_parallel_max_depth = (int)val->v.int_value; } if (!strcmp(fname, "flowlog_parallel_or_nesting")) { if (val->tag != PL_TERM_INT || val->v.int_value < 0) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_parallel_or_nesting", dbg_dat_ptr); } prog->flag_parallel_or_nesting = (int)val->v.int_value; } if (!strcmp(fname, "flowlog_engine")) { if (val->tag != PL_TERM_ATOM || !val->v.atom_name || (strcmp(val->v.atom_name, "interp") && strcmp(val->v.atom_name, "tree") && strcmp(val->v.atom_name, "wam") && strcmp(val->v.atom_name, "wamvm"))) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for flowlog_engine", dbg_dat_ptr); } if (!strcmp(val->v.atom_name, "wam")) { prog->flag_engine = PL_ENGINE_WAM; } else if (!strcmp(val->v.atom_name, "wamvm")) { prog->flag_engine = PL_ENGINE_WAMVM; } else { prog->flag_engine = PL_ENGINE_INTERP; } } if (!strcmp(fname, "occurs_check")) { if (val->tag != PL_TERM_ATOM || !val->v.atom_name || (strcmp(val->v.atom_name, "true") && strcmp(val->v.atom_name, "false"))) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid set_prolog_flag/2 directive value for occurs_check", dbg_dat_ptr); } prog->flag_occurs_check = !strcmp(val->v.atom_name, "true"); } } } if (g && g->tag == PL_TERM_STRUCT && g->v.str.arity == 1 && !strcmp(g->v.str.functor, "dynamic")) { // Execute dynamic/1 at load time (ISO-ish): mark predicates as dynamic. pl_term *pis = g->v.str.args[0]; if (!pis) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid dynamic/1 directive", dbg_dat_ptr); } const pl_term *cur = pis; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { if (!cur) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid dynamic/1 directive", dbg_dat_ptr); } const pl_term *pi = cur; const bool list_mode = term_is_list_pair(cur); if (list_mode) { if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid dynamic/1 directive list", dbg_dat_ptr); } pi = cur->v.str.args[0]; cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, NULL)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid dynamic/1 directive list", dbg_dat_ptr); } } else { cur = NULL; // single predicate indicator } if (!pi || pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid dynamic/1 directive predicate indicator", dbg_dat_ptr); } pl_term *name_term = pi->v.str.args[0]; pl_term *arity_term = pi->v.str.args[1]; if (!name_term || name_term->tag != PL_TERM_ATOM || !arity_term || arity_term->tag != PL_TERM_INT) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid dynamic/1 directive predicate indicator", dbg_dat_ptr); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0 || arity_val > 1024) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid dynamic/1 directive arity", dbg_dat_ptr); } prog_dyn_pred_add(prog, name_term->v.atom_name, (ULO)arity_val, rt_ctrl, dbg_dat_ptr); if (!list_mode) { break; } } } if (g && g->tag == PL_TERM_STRUCT && g->v.str.arity == 1 && !strcmp(g->v.str.functor, "table")) { // Flowlog extension: `:- table/1` (call-by-variant tabling). pl_term *pis = g->v.str.args[0]; if (!pis) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid table/1 directive", dbg_dat_ptr); } const pl_term *cur = pis; pl_list_cycle_guard cg; list_cycle_guard_init(&cg, cur); while (1) { if (!cur) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid table/1 directive", dbg_dat_ptr); } const pl_term *pi = cur; const bool list_mode = term_is_list_pair(cur); if (list_mode) { if (term_is_nil(cur)) { break; } if (!term_is_list_pair(cur)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid table/1 directive list", dbg_dat_ptr); } pi = cur->v.str.args[0]; cur = cur->v.str.args[1]; if (list_cycle_guard_step_tr(&cg, NULL)) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid table/1 directive list", dbg_dat_ptr); } } else { cur = NULL; // single predicate indicator } if (!pi || pi->tag != PL_TERM_STRUCT || pi->v.str.arity != 2 || strcmp(pi->v.str.functor, "/")) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid table/1 directive predicate indicator", dbg_dat_ptr); } pl_term *name_term = pi->v.str.args[0]; pl_term *arity_term = pi->v.str.args[1]; if (!name_term || name_term->tag != PL_TERM_ATOM || !arity_term || arity_term->tag != PL_TERM_INT) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid table/1 directive predicate indicator", dbg_dat_ptr); } const SLO arity_val = arity_term->v.int_value; if (arity_val < 0 || arity_val > 1024) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid table/1 directive arity", dbg_dat_ptr); } prog_tabled_pred_add(prog, name_term->v.atom_name, (ULO)arity_val, rt_ctrl, dbg_dat_ptr); if (!list_mode) { break; } } } } continue; } ULO cl_line = 0; ULO cl_col = 0; compute_line_col(src, tk.start, &cl_line, &cl_col); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); pl_var_table vt = {0}; // Parse clause heads with a wide precedence range, but keep it below 1200 so that ':-' remains available as the // rule separator token. pl_term *head = parse_term(&p, &vt, scope, true, 1199); if (!head) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid clause head", dbg_dat_ptr); } // Optional rule body. pl_term **body0 = NULL; ULO body_count = 0; ULO body_cap = 0; if (accept_tok(&p, TOK_COLON_DASH)) { pl_term *body = parse_term(&p, &vt, scope, true, 1200); if (!body) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: invalid clause body", dbg_dat_ptr); } flatten_conjunction_goals(&p, body, &body0, &body_count, &body_cap); } expect_tok(&p, TOK_DOT); pl_clause *cl = (pl_clause *)pool_alloc(rt_ctrl, sizeof(*cl), dbg_dat_ptr); cl->head = head; cl->body_count = body_count; cl->scope = scope; cl->env = NULL; cl->src_name = clause_src_name; cl->src_line = cl_line; cl->src_col = cl_col; cl->var_count = vt.count; if (body_count) { cl->body = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * (body_count + 1), dbg_dat_ptr); cl->body[0] = NULL; for (ULO i = 0; i < body_count; i++) { cl->body[i + 1] = body0[i]; } } else { cl->body = NULL; } clause_compute_tpl_sizes(cl); if (prog->clause_count == clauses_cap) { ULO new_cap = clauses_cap * 2; pl_clause **new_clauses = (pl_clause **)pool_alloc(rt_ctrl, sizeof(pl_clause *) * (new_cap + 1), dbg_dat_ptr); memcpy(new_clauses, prog->clauses, sizeof(pl_clause *) * (clauses_cap + 1)); new_clauses[0] = NULL; prog->clauses = new_clauses; clauses_cap = new_cap; prog->clause_cap = clauses_cap; } prog->clause_count++; prog->clauses[prog->clause_count] = cl; if (!body_count) { if (prog->fact_count == facts_cap) { ULO new_cap = facts_cap * 2; pl_term **new_facts = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * (new_cap + 1), dbg_dat_ptr); memcpy(new_facts, prog->facts, sizeof(pl_term *) * (facts_cap + 1)); new_facts[0] = NULL; prog->facts = new_facts; facts_cap = new_cap; prog->fact_cap = facts_cap; } prog->fact_count++; prog->facts[prog->fact_count] = head; } } } static pl_query *parse_query_src(const void *rt_ctrl, const ULO *dbg_dat_ptr, const pl_program *prog, const CHR *src) { if (!src) { return NULL; } // Optional "?-" prefix (common at the prompt) const CHR *s = src; while (*s && isspace((unsigned char)*s)) { s++; } if (s[0] == '?' && s[1] == '-') { s += 2; } pl_query *q = (pl_query *)pool_alloc(rt_ctrl, sizeof(*q), dbg_dat_ptr); memset(q, 0, sizeof(*q)); pl_var_table vt = {0}; pl_parse p = {0}; p.src_name = ""; p.rt_ctrl = rt_ctrl; p.dbg_dat_ptr = dbg_dat_ptr; p.ops = prog ? prog->op_overrides : NULL; p.double_quotes = prog ? prog->flag_double_quotes : PL_DQ_CHARS; const bool char_conv_on = prog ? prog->flag_char_conversion : false; const unsigned char *char_conv_table = prog ? prog->char_conv_table : NULL; p.character_escapes = prog ? prog->flag_character_escapes : true; lex_init(&p.lx, s, char_conv_on, char_conv_table, p.character_escapes); pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); memset(scope, 0, sizeof(*scope)); q->scope = scope; // Parse a query as a goal term (operators supported), then flatten top-level conjunctions. pl_term **goals0 = NULL; ULO goal_count = 0; ULO goal_cap = 0; pl_term *term = parse_term(&p, &vt, q->scope, true, 1200); if (term) { flatten_conjunction_goals(&p, term, &goals0, &goal_count, &goal_cap); } (void)accept_tok(&p, TOK_DOT); // allow optional trailing dot if (peek_tok(&p).type != TOK_EOF) { rise_error_info_dbg(ECODE_RT__FLOWLOG_PARSE, "flowlog: unexpected trailing tokens in query", dbg_dat_ptr); } // Finalize var table q->var_count = vt.count; if (q->var_count) { q->var_names = (CHR **)pool_alloc(rt_ctrl, sizeof(CHR *) * q->var_count, dbg_dat_ptr); for (ULO i = 0; i < q->var_count; i++) { q->var_names[i] = vt.names[i]; } } else { q->var_names = NULL; } // Finalize goals (1-based indexing). q->goal_count = goal_count; if (q->goal_count) { q->goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * (q->goal_count + 1), dbg_dat_ptr); q->goals[0] = NULL; for (ULO i = 0; i < q->goal_count; i++) { q->goals[i + 1] = goals0[i]; } q->term = q->goals[1]; } else { q->goals = NULL; q->term = NULL; } return q; } static bool join_builtin_supported(const CHR *name, ULO arity) { if (!name) { return false; } if (arity == 0) { return !strcmp(name, "true") || !strcmp(name, "fail") || !strcmp(name, "false"); } if (arity == 1) { return !strcmp(name, "var") || !strcmp(name, "nonvar") || !strcmp(name, "atom") || !strcmp(name, "integer") || !strcmp(name, "float") || !strcmp(name, "number") || !strcmp(name, "atomic") || !strcmp(name, "compound") || !strcmp(name, "callable"); } if (arity == 2) { return !strcmp(name, ",") || !strcmp(name, ";") || !strcmp(name, "=") || !strcmp(name, "\\=") || !strcmp(name, "==") || !strcmp(name, "\\==") || !strcmp(name, "=@=") || !strcmp(name, "\\=@=") || !strcmp(name, "@<") || !strcmp(name, "@=<") || !strcmp(name, "@>") || !strcmp(name, "@>=") || !strcmp(name, "is") || !strcmp(name, "=:=") || !strcmp(name, "=\\=") || !strcmp(name, "<") || !strcmp(name, "=<") || !strcmp(name, ">") || !strcmp(name, ">="); } return false; } static ULO join_count_flatten_conj(pl_term *t, const pl_env *env, ULO depth) { t = deref_term(t, env); if (!t || FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return 0; } if (t->tag == PL_TERM_STRUCT && t->v.str.arity == 2 && t->v.str.args && ((pl_builtin_id)t->builtin == PL_BI_COMMA_2)) { return join_count_flatten_conj(t->v.str.args[0], env, depth + 1) + join_count_flatten_conj(t->v.str.args[1], env, depth + 1); } return 1; } static void join_flatten_conj(pl_term *t, const pl_env *env, pl_term **out, ULO *io_count, ULO depth) { t = deref_term(t, env); if (!t || !out || !io_count || FLOWLOG_DEPTH_LIMIT_EXCEEDED(depth, FLOWLOG_DEPTH_LIMIT)) { return; } if (t->tag == PL_TERM_STRUCT && t->v.str.arity == 2 && t->v.str.args && ((pl_builtin_id)t->builtin == PL_BI_COMMA_2)) { join_flatten_conj(t->v.str.args[0], env, out, io_count, depth + 1); join_flatten_conj(t->v.str.args[1], env, out, io_count, depth + 1); return; } out[(*io_count)++] = t; } static pl_cut_signal join_solve_facts(pl_program *prog, const pl_query *q, pl_term *const *goals, ULO goal_count, const pl_env *env_in, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr, ULO depth) { if (!prog || !q || !sol_count) { return cut_none(); } if (goal_count == 0) { if (out) { if (g_solution_capture && g_solution_capture->out == out) { const size_t start = out->len; env_to_sbuf(q, env_in, out, dbg_dat_ptr); (void)solution_capture_mark(out, start); } else { if (*sol_count) { sbuf_append_cstr(out, "\n; "); } else { sbuf_append_cstr(out, " "); } env_to_sbuf(q, env_in, out, dbg_dat_ptr); } } (*sol_count)++; return cut_none(); } pl_term *goal0 = goals ? deref_term(goals[0], env_in) : NULL; if (!goal0) { return cut_none(); } const CHR *pred_name = NULL; ULO pred_arity = 0; if (goal0->tag == PL_TERM_ATOM) { pred_name = goal0->v.atom_name; pred_arity = 0; } else if (goal0->tag == PL_TERM_STRUCT) { pred_name = goal0->v.str.functor; pred_arity = goal0->v.str.arity; } else { // Non-callable goal: fall back to the full engine in the caller. return cut_none(); } if (!pred_name) { return cut_none(); } // Supported built-in filters: evaluate and continue (facts join stays in the fast path). if (builtin_pred_defined(pred_name, pred_arity)) { if (!join_builtin_supported(pred_name, pred_arity)) { return cut_none(); } if (pred_arity == 0) { if ((pl_builtin_id)goal0->builtin == PL_BI_TRUE_0) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } // fail/false return cut_none(); } if (pred_arity == 1 && goal0->tag == PL_TERM_STRUCT && goal0->v.str.args) { pl_term *arg0 = deref_term(goal0->v.str.args[0], env_in); if (!arg0) { return cut_none(); } bool ok = false; if (!strcmp(pred_name, "var")) { ok = (arg0->tag == PL_TERM_VAR); } else if (!strcmp(pred_name, "nonvar")) { ok = (arg0->tag != PL_TERM_VAR); } else if (!strcmp(pred_name, "atom")) { ok = (arg0->tag == PL_TERM_ATOM); } else if (!strcmp(pred_name, "integer")) { ok = term_is_integer(arg0); } else if (!strcmp(pred_name, "float")) { ok = (arg0->tag == PL_TERM_FLOAT); } else if (!strcmp(pred_name, "number")) { ok = term_is_number(arg0); } else if (!strcmp(pred_name, "atomic")) { ok = term_is_atomic_term(arg0); } else if (!strcmp(pred_name, "compound")) { ok = (arg0->tag == PL_TERM_STRUCT); } else if (!strcmp(pred_name, "callable")) { ok = (arg0->tag == PL_TERM_ATOM) || (arg0->tag == PL_TERM_STRUCT); } if (ok) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); } if (pred_arity == 2 && goal0->tag == PL_TERM_STRUCT && goal0->v.str.args) { switch ((pl_builtin_id)goal0->builtin) { case PL_BI_COMMA_2: { pl_term *a = deref_term(goal0->v.str.args[0], env_in); pl_term *b = deref_term(goal0->v.str.args[1], env_in); if (!a || !b) { return cut_none(); } const ULO rest = goal_count - 1; const ULO ac = join_count_flatten_conj(a, env_in, 0); const ULO bc = join_count_flatten_conj(b, env_in, 0); const ULO new_goal_count = ac + bc + rest; pl_term **new_goals = NULL; if (new_goal_count) { new_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * new_goal_count, dbg_dat_ptr); } ULO pos = 0; join_flatten_conj(a, env_in, new_goals, &pos, 0); join_flatten_conj(b, env_in, new_goals, &pos, 0); for (ULO i = 1; i < goal_count; i++) { new_goals[pos++] = goals[i]; } return join_solve_facts(prog, q, new_goals, new_goal_count, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } case PL_BI_SEMI_2: { pl_term *a = deref_term(goal0->v.str.args[0], env_in); pl_term *b = deref_term(goal0->v.str.args[1], env_in); if (!a || !b) { return cut_none(); } const ULO rest = goal_count - 1; const ULO ac = join_count_flatten_conj(a, env_in, 0); const ULO bc = join_count_flatten_conj(b, env_in, 0); const ULO left_goal_count = ac + rest; pl_term **left_goals = NULL; if (left_goal_count) { left_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * left_goal_count, dbg_dat_ptr); } ULO pos = 0; join_flatten_conj(a, env_in, left_goals, &pos, 0); for (ULO i = 1; i < goal_count; i++) { left_goals[pos++] = goals[i]; } pl_cut_signal r = join_solve_facts(prog, q, left_goals, left_goal_count, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); if (r.except || r.cut) { return r; } const ULO right_goal_count = bc + rest; pl_term **right_goals = NULL; if (right_goal_count) { right_goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * right_goal_count, dbg_dat_ptr); } pos = 0; join_flatten_conj(b, env_in, right_goals, &pos, 0); for (ULO i = 1; i < goal_count; i++) { right_goals[pos++] = goals[i]; } return join_solve_facts(prog, q, right_goals, right_goal_count, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } case PL_BI_UNIFY_2: { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal0->v.str.args[0], goal0->v.str.args[1], env1, rt_ctrl, dbg_dat_ptr)) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env1, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); } case PL_BI_NOT_UNIFY_2: { pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal0->v.str.args[0], goal0->v.str.args[1], env1, rt_ctrl, dbg_dat_ptr)) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); } case PL_BI_IDENTICAL_2: if (term_identical_env(goal0->v.str.args[0], goal0->v.str.args[1], env_in)) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); case PL_BI_NOT_IDENTICAL_2: if (!term_identical_env(goal0->v.str.args[0], goal0->v.str.args[1], env_in)) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); case PL_BI_VARIANT_2: if (term_variant_env(goal0->v.str.args[0], goal0->v.str.args[1], env_in, dbg_dat_ptr)) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); case PL_BI_NOT_VARIANT_2: if (!term_variant_env(goal0->v.str.args[0], goal0->v.str.args[1], env_in, dbg_dat_ptr)) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); case PL_BI_TERM_LT_2: case PL_BI_TERM_LTE_2: case PL_BI_TERM_GT_2: case PL_BI_TERM_GTE_2: { pl_var_stack st; var_stack_init(&st); const int r = compare_std_terms(goal0->v.str.args[0], goal0->v.str.args[1], env_in, &st, dbg_dat_ptr, 0); var_stack_free(&st); bool ok = false; switch ((pl_builtin_id)goal0->builtin) { case PL_BI_TERM_LT_2: ok = (r < 0); break; case PL_BI_TERM_LTE_2: ok = (r <= 0); break; case PL_BI_TERM_GT_2: ok = (r > 0); break; case PL_BI_TERM_GTE_2: ok = (r >= 0); break; default: break; } if (ok) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); } case PL_BI_IS_2: { pl_number val = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex(goal0->v.str.args[1], env_in, &val, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(NULL, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt( rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal0->v.str.args[1], env_in); } return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal0->v.str.args[1], env_in); } return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, "is", 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(NULL, rt_ctrl, dbg_dat_ptr, "zero_divisor", "is", 2); } return throw_evaluation_error(NULL, rt_ctrl, dbg_dat_ptr, "undefined", "is", 2); } pl_term *rhs = num_to_term_rt(val, rt_ctrl, dbg_dat_ptr); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); if (unify_terms(goal0->v.str.args[0], rhs, env1, rt_ctrl, dbg_dat_ptr)) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env1, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); } case PL_BI_NUM_EQ_2: case PL_BI_NUM_NE_2: case PL_BI_NUM_LT_2: case PL_BI_NUM_LTE_2: case PL_BI_NUM_GT_2: case PL_BI_NUM_GTE_2: { pl_number a = {0}, b = {0}; pl_arith_error aerr = {0}; if (!eval_num_expr_ex(goal0->v.str.args[0], env_in, &a, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(NULL, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt( rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, pred_name, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal0->v.str.args[0], env_in); } return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, pred_name, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal0->v.str.args[0], env_in); } return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, pred_name, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(NULL, rt_ctrl, dbg_dat_ptr, "zero_divisor", pred_name, 2); } return throw_evaluation_error(NULL, rt_ctrl, dbg_dat_ptr, "undefined", pred_name, 2); } memset(&aerr, 0, sizeof(aerr)); if (!eval_num_expr_ex(goal0->v.str.args[1], env_in, &b, &aerr, 0, rt_ctrl, dbg_dat_ptr)) { if (aerr.kind == PL_ARITH_ERR_INSTANTIATION) { return throw_instantiation_error(NULL, rt_ctrl, dbg_dat_ptr, "not_sufficiently_instantiated"); } if (aerr.kind == PL_ARITH_ERR_TYPE_EVALUABLE) { pl_term *pi = make_pred_indicator_rt( rt_ctrl, dbg_dat_ptr, aerr.evaluable_name ? aerr.evaluable_name : "", aerr.evaluable_arity); return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "evaluable", pi, env_in, pred_name, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_INTEGER) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal0->v.str.args[1], env_in); } return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "integer", cul, env_in, pred_name, 2); } if (aerr.kind == PL_ARITH_ERR_TYPE_FLOAT) { pl_term *cul = (pl_term *)aerr.culprit; if (!cul) { cul = deref_term(goal0->v.str.args[1], env_in); } return throw_type_error(NULL, rt_ctrl, dbg_dat_ptr, "float", cul, env_in, pred_name, 2); } if (aerr.kind == PL_ARITH_ERR_EVAL_ZERO_DIVISOR) { return throw_evaluation_error(NULL, rt_ctrl, dbg_dat_ptr, "zero_divisor", pred_name, 2); } return throw_evaluation_error(NULL, rt_ctrl, dbg_dat_ptr, "undefined", pred_name, 2); } bool ok = false; if (!num_is_float(a) && !num_is_float(b)) { const int cmp = num_cmp(a, b); switch ((pl_builtin_id)goal0->builtin) { case PL_BI_NUM_EQ_2: ok = (cmp == 0); break; case PL_BI_NUM_NE_2: ok = (cmp != 0); break; case PL_BI_NUM_LT_2: ok = (cmp < 0); break; case PL_BI_NUM_LTE_2: ok = (cmp <= 0); break; case PL_BI_NUM_GT_2: ok = (cmp > 0); break; case PL_BI_NUM_GTE_2: ok = (cmp >= 0); break; default: break; } } else { const double da = num_as_double(a); const double db = num_as_double(b); switch ((pl_builtin_id)goal0->builtin) { case PL_BI_NUM_EQ_2: ok = (da == db); break; case PL_BI_NUM_NE_2: ok = (da != db); break; case PL_BI_NUM_LT_2: ok = (da < db); break; case PL_BI_NUM_LTE_2: ok = (da <= db); break; case PL_BI_NUM_GT_2: ok = (da > db); break; case PL_BI_NUM_GTE_2: ok = (da >= db); break; default: break; } } if (ok) { return join_solve_facts( prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env_in, out, sol_count, rt_ctrl, dbg_dat_ptr, depth); } return cut_none(); } default: break; } return cut_none(); } return cut_none(); } // ISO-ish unknown procedure handling (prolog_flag unknown). bool dyn = false; if (!prog_pred_defined(prog, pred_name, pred_arity, &dyn)) { if (prog->flag_unknown == PL_UNKNOWN_FAIL) { return cut_none(); } if (prog->flag_unknown == PL_UNKNOWN_WARNING) { streams_init(dbg_dat_ptr); pl_stream *s = NULL; if (!stream_lookup(2, &s, dbg_dat_ptr) || !s || !s->writable) { (void)fprintf(stderr, "Warning: unknown procedure: %s/%lu\n", pred_name, (unsigned long)pred_arity); } else { (void)fprintf(s->fp, "Warning: unknown procedure: %s/%lu\n", pred_name, (unsigned long)pred_arity); (void)fflush(s->fp); } return cut_none(); } pl_term *pi = make_pred_indicator_rt(rt_ctrl, dbg_dat_ptr, pred_name, pred_arity); return throw_existence_error(NULL, rt_ctrl, dbg_dat_ptr, "procedure", pi, env_in, pred_name, pred_arity); } // Candidate facts for this predicate call (ordered, logical view). const pl_clause **cands = NULL; ULO cand_count = 0; if (prog->clauses && prog->clause_count) { cands = prog_snapshot_pred_cands(prog, pred_name, pred_arity, goal0, env_in, &cand_count, rt_ctrl, dbg_dat_ptr); } if (!cands || !cand_count) { // Defined but no clauses: fail. return cut_none(); } const bool par_or = prog && g_par_state && (cand_count > 1) && !flowlog_cancelled() && (depth == 0); if (par_or) { const uint64_t orpar_t0 = flowlog_monotonic_ns(); ULO worker_count = orpar_worker_count_for_alts(cand_count, (ULO)g_par_state->max_threads); int remote_taken = 0; if (g_par_budget) { remote_taken = par_global_budget_take_up_to(g_par_budget, (int)(worker_count - 1)); worker_count = (ULO)(1 + remote_taken); } if (worker_count < 2) { if (g_par_budget && remote_taken) { par_global_budget_give(g_par_budget, remote_taken); } } else { ULO chunk_count = worker_count * 128; const ULO chunk_cap = 16384; if (chunk_count > chunk_cap) { chunk_count = chunk_cap; } if (chunk_count > cand_count) { chunk_count = cand_count; } if (!chunk_count) { chunk_count = cand_count; } pl_or_job *workers = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*workers) * worker_count, dbg_dat_ptr); memset(workers, 0, sizeof(*workers) * worker_count); pl_or_job *chunks = (pl_or_job *)pool_alloc(rt_ctrl, sizeof(*chunks) * chunk_count, dbg_dat_ptr); memset(chunks, 0, sizeof(*chunks) * chunk_count); pl_or_work *work = (pl_or_work *)pool_alloc(rt_ctrl, sizeof(*work), dbg_dat_ptr); memset(work, 0, sizeof(*work)); work->count = worker_count; work->jobs = workers; work->chunk_count = chunk_count; work->chunks = chunks; work->unordered = (prog->flag_parallel_or_order == PL_OR_UNORDERED); atomic_init(&work->next_chunk, 0); atomic_init(&work->commit_chunk, 0); atomic_init(&work->max_chunk, (unsigned long)(chunk_count ? (chunk_count - 1) : 0)); atomic_init(&work->done, 0); atomic_init(&work->cancel, 0); work->par_budget = g_par_budget; atomic_init(&work->budget_returned, 0); work->budget_total = remote_taken; work->alloc_snapshot = NULL; work->dbg_t0_ns = orpar_t0; atomic_init(&work->dbg_first_cut_chunk, (unsigned long)ULONG_MAX); for (ULO i = 0; i < chunk_count; i++) { const ULO start = (ULO)(((unsigned __int128)i * (unsigned __int128)cand_count) / (unsigned __int128)chunk_count); ULO end = (ULO)(((unsigned __int128)(i + 1) * (unsigned __int128)cand_count) / (unsigned __int128)chunk_count); if (end > cand_count) { end = cand_count; } chunks[i] = (pl_or_job){ .kind = ((end - start) == 1) ? PL_OR_JOB_JOIN_CLAUSE : PL_OR_JOB_JOIN_CLAUSE_RANGE, .prog = prog, .q = q, .goal = goal0, .env_in = env_in, .drop = NULL, .rest_goals = (goals && goal_count > 1) ? (pl_term *const *)(goals + 1) : NULL, .rest_count = goal_count ? (goal_count - 1) : 0, .cut_barrier = NULL, .exc_barrier = NULL, .depth = depth, .stop_at_first = false, .capture_solution_output = (out != NULL) || (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .capture_solution_spans = (atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed) != 0), .local_alloc_ok = true, .stringify_exceptions = false, .chunk_index = i, .work_done = NULL, // chunk completion is tracked via job->done .work_cancel = &work->cancel, }; atomic_init(&chunks[i].done, 0); if ((end - start) == 1) { chunks[i].u.cl = cands[start]; } else { chunks[i].u.clause_range.cands = cands; chunks[i].u.clause_range.start = start; chunks[i].u.clause_range.end = end; } } for (ULO i = 0; i < worker_count; i++) { workers[i] = (pl_or_job){ .kind = PL_OR_JOB_WORKER, .prog = prog, .work_done = &work->done, .work_cancel = &work->cancel, }; workers[i].u.worker.work = work; workers[i].budget_return = (i == 0) ? 0 : 1; atomic_init(&workers[i].done, 0); } pl_cut_signal ret = cut_none(); bool stopped = false; const ULO started = flowlog_start_or_work(work, 2, rt_ctrl, dbg_dat_ptr); if (g_par_budget && remote_taken && ((int)started < remote_taken)) { par_global_budget_give(g_par_budget, remote_taken - (int)started); remote_taken = (int)started; work->budget_total = remote_taken; } if (!work->unordered) { ULO last_done = 0; for (ULO i = 0; i < chunk_count; i++) { atomic_store(&work->commit_chunk, (unsigned long)i); pl_or_job *j = &chunks[i]; while (!atomic_load(&j->done)) { if (flowlog_cancelled()) { break; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); last_done = i + 1; if (stopped) { break; } } // Ensure workers have stopped before cleaning up remaining chunk outputs. if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); if (stopped && (last_done < chunk_count)) { for (ULO i = last_done; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } } else { ULO done_count = 0; ULO scan = 0; while (done_count < chunk_count) { if (flowlog_cancelled()) { break; } bool progressed = false; for (ULO n = 0; n < chunk_count; n++) { const ULO idx = (scan + n) % chunk_count; pl_or_job *j = &chunks[idx]; const int done = atomic_load(&j->done); if (done != 1) { continue; } done_count++; scan = idx + 1; progressed = true; pl_or_merge_output(out, g_stdio_capture, sol_count, j); if (j->sig.except) { if (j->except_snapshot) { par_state_adopt_snapshot(g_par_state, j->except_snapshot); j->except_snapshot = NULL; } ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } else if (j->sig.cut) { ret = j->sig; stopped = true; atomic_store(&work->cancel, 1); } pl_or_job_dispose(j, rt_ctrl, dbg_dat_ptr); atomic_store(&j->done, 2); if (stopped) { break; } } if (stopped) { break; } if (progressed) { continue; } if (atomic_load_explicit(&work->cancel, memory_order_relaxed)) { usleep(1000); continue; } unsigned long idx = 0; if (orpar_try_claim_chunk(work, &idx)) { pl_or_job_run(&chunks[(ULO)idx], rt_ctrl, dbg_dat_ptr); continue; } usleep(1000); } // Ensure workers have stopped before cleaning up remaining chunk outputs. if (stopped) { atomic_store(&work->cancel, 1); } const int expected = (int)started; if (expected > 0) { flowlog_wait_done(&work->done, expected); } pl_or_work_budget_reconcile(work); for (ULO i = 0; i < chunk_count; i++) { pl_or_job_dispose(&chunks[i], rt_ctrl, dbg_dat_ptr); } } flowlog_debug_orpar_log_stop(pred_name, pred_arity, cand_count, flowlog_monotonic_ns() - orpar_t0, stopped, atomic_load(&work->cancel) != 0); return ret; } } for (ULO ci = 0; ci < cand_count; ci++) { const pl_clause *cl = cands[ci]; if (!cl || !cl->head || cl->body_count) { continue; } const bool release_temp = (g_temp_alloc != NULL); pl_temp_mark tm = {0}; if (release_temp) { tm = temp_alloc_mark(g_temp_alloc); } pl_scope *scope = (pl_scope *)pool_alloc(rt_ctrl, sizeof(*scope), dbg_dat_ptr); pl_term_arena arena = clause_arena_alloc(cl, rt_ctrl, dbg_dat_ptr); pl_term *head = clone_term_with_scope_arena(cl->head, cl->scope, scope, &arena, dbg_dat_ptr, 0); pl_env *env1 = env_clone(env_in, rt_ctrl, dbg_dat_ptr); env1->intro_scope = scope; env_apply_clause_bindings_arena(cl, scope, env1, &arena, rt_ctrl, dbg_dat_ptr); if (!unify_terms(goal0, head, env1, rt_ctrl, dbg_dat_ptr)) { if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } continue; } pl_cut_signal r = join_solve_facts(prog, q, goals ? (goals + 1) : NULL, goal_count - 1, env1, out, sol_count, rt_ctrl, dbg_dat_ptr, depth + 1); if (r.except) { return r; } if (release_temp) { temp_alloc_release(g_temp_alloc, tm, rt_ctrl, dbg_dat_ptr); } } return cut_none(); } /* ============================================================================ * SECTION 26: CLI & REPL * command-line parsing and interactive REPL. * ============================================================================ */ /* --- SUBSECTION 26.1: Usage & Flags -------------------------------------- */ // CLI usage, flags, and helpers. // flowlog_usage() prints help; flowlog_parse_size_bytes() parses size flags; flowlog_program_free() and flowlog_write_fd_mem() manage CLI resources. static bool flowlog_parse_size_bytes(const char *s, size_t *out) { if (out) { *out = 0; } if (!s || !*s || !out) { return false; } char *end = NULL; const unsigned long long base = strtoull(s, &end, 10); if (!end || end == s) { return false; } unsigned long long mult = 1; if (end && *end) { const char c = end[0]; const char d = end[1]; const char e = end[2]; if ((d == '\0') || (((d == 'b') || (d == 'B')) && e == '\0')) { if (c == 'k' || c == 'K') { mult = 1024ull; } else if (c == 'm' || c == 'M') { mult = 1024ull * 1024ull; } else if (c == 'g' || c == 'G') { mult = 1024ull * 1024ull * 1024ull; } else { return false; } } else { return false; } } if (mult != 1 && base > ULLONG_MAX / mult) { *out = SIZE_MAX; return true; } const unsigned long long v = base * mult; if (v > (unsigned long long)SIZE_MAX) { *out = SIZE_MAX; return true; } *out = (size_t)v; return true; } static void flowlog_usage(FILE *f) { (void)fprintf(f, "Usage:\n" " flowlog [system-args] [file [file-args ...] ...]\n" "System args (must appear before first file to load):\n" " -l file.pl load file after rc (repeat for more)\n" " -f/--fast skip rc startup loading\n" " -g/--goal/--query \"query.\" run one-shot query\n" " --threads N set worker thread count\n" " --engine wam|wamvm|interp|tree default: wamvm\n" " --parallel-profile off|iso|fast default: fast\n" " --trace enable Prolog-style trace (stderr)\n" " --notrace disable Prolog-style trace\n" " --itrace enable internal (C/VM) trace (stderr)\n" " --noitrace disable internal (C/VM) trace\n" " --itrace-watermark only emit itrace lines on new C-stack peaks\n" " --noitrace-watermark disable itrace watermark mode\n" " --cstack-limit BYTES soft C-stack limit (throws resource_error(stack))\n" #if defined(SIGSEGV) " --segv-trace dump last trace frames on SIGSEGV\n" " --nosegv-trace disable SIGSEGV trace dumping\n" #endif " -v/--version show version of flowlog\n" " -h/--help show this help message and exit\n" "Notes:\n" " Flowlog system arguments are specified before the file to load.\n" " After the first positional file, each existing file token starts a new file segment.\n" " Tokens between file segments are application arguments for that file.\n"); } static CHR *flowlog_read_entire_file(const char *path, size_t *out_len) { if (out_len) { *out_len = 0; } if (!path || !*path) { return NULL; } int fd = open(path, O_RDONLY); if (fd < 0) { return NULL; } CHR *buf = flowlog_read_fd_all(fd, out_len); (void)close(fd); return buf; } static pl_program *flowlog_program_from_src(const CHR *src, const char *src_name, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!src) { src = ""; } if (!src_name || !*src_name) { src_name = ""; } pl_temp_alloc *saved_tmp = g_temp_alloc; pl_temp_alloc tmp = {0}; g_temp_alloc = &tmp; pl_program *prog = parse_program_src(rt_ctrl, dbg_dat_ptr, src, src_name); if (prog) { prog->alloc_snapshot = temp_snapshot_from_temp_alloc(&tmp, rt_ctrl, dbg_dat_ptr); temp_alloc_drop_lists(&tmp); } else { temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); } g_temp_alloc = saved_tmp; return prog; } static void flowlog_program_free(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog) { return; } pl_temp_snapshot *snap = prog->alloc_snapshot; prog->alloc_snapshot = NULL; if (snap) { temp_snapshot_free_all(snap, rt_ctrl, dbg_dat_ptr); } } static CHR **flowlog_program_copy_argv_items( const CHR *const *argv, ULO argc, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!argc) { return NULL; } CHR **items = (CHR **)pool_alloc(rt_ctrl, sizeof(CHR *) * argc, dbg_dat_ptr); if (!items) { return NULL; } for (ULO i = 0; i < argc; i++) { items[i] = pool_strdup(rt_ctrl, (argv && argv[i]) ? argv[i] : "", dbg_dat_ptr); if (!items[i]) { return NULL; } } return items; } static bool flowlog_program_set_default_argv( pl_program *prog, const CHR *const *argv, ULO argc, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog) { return false; } prog->flag_argv_default_count = 0; prog->flag_argv_default = NULL; prog->flag_argv_count = 0; prog->flag_argv = NULL; if (!argv || !argc) { return true; } CHR **items = flowlog_program_copy_argv_items(argv, argc, rt_ctrl, dbg_dat_ptr); if (!items) { return false; } prog->flag_argv_default = items; prog->flag_argv_default_count = argc; prog->flag_argv = items; prog->flag_argv_count = argc; return true; } static void flowlog_program_use_default_argv(pl_program *prog) { if (!prog) { return; } prog->flag_argv = prog->flag_argv_default; prog->flag_argv_count = prog->flag_argv_default_count; } static bool flowlog_program_add_src_argv( pl_program *prog, const CHR *src_name, const CHR *const *argv, ULO argc, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!prog || !src_name || !*src_name) { return false; } if (prog->flag_argv_src_count == prog->flag_argv_src_cap) { ULO new_cap = prog->flag_argv_src_cap ? (prog->flag_argv_src_cap * 2) : 4; pl_program_argv_src *ni = (pl_program_argv_src *)pool_alloc(rt_ctrl, sizeof(pl_program_argv_src) * new_cap, dbg_dat_ptr); if (!ni) { return false; } memset(ni, 0, sizeof(pl_program_argv_src) * new_cap); if (prog->flag_argv_srcs && prog->flag_argv_src_count) { memcpy(ni, prog->flag_argv_srcs, sizeof(pl_program_argv_src) * prog->flag_argv_src_count); } prog->flag_argv_srcs = ni; prog->flag_argv_src_cap = new_cap; } pl_program_argv_src *e = &prog->flag_argv_srcs[prog->flag_argv_src_count++]; memset(e, 0, sizeof(*e)); e->src_name = pool_strdup(rt_ctrl, src_name, dbg_dat_ptr); if (!e->src_name) { return false; } e->argc = argc; if (argc) { e->argv = flowlog_program_copy_argv_items(argv, argc, rt_ctrl, dbg_dat_ptr); if (!e->argv) { return false; } } return true; } static bool flowlog_program_use_src_argv(pl_program *prog, const CHR *src_name, bool fallback_default) { if (!prog) { return false; } const pl_program_argv_src *e = flowlog_program_find_src_argv(prog, src_name); if (e) { prog->flag_argv = e->argv; prog->flag_argv_count = e->argc; return true; } if (fallback_default) { flowlog_program_use_default_argv(prog); } else { prog->flag_argv = NULL; prog->flag_argv_count = 0; } return false; } static pl_program *flowlog_program_load_file(const char *path, const void *rt_ctrl, const ULO *dbg_dat_ptr) { size_t n = 0; CHR *src = flowlog_read_entire_file(path, &n); if (!src) { return NULL; } pl_program *prog = flowlog_program_from_src(src, path, rt_ctrl, dbg_dat_ptr); free(src); return prog; } static pl_program *flowlog_program_load_files(const char *const *paths, size_t count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!paths || !count) { return flowlog_program_from_src("", "", rt_ctrl, dbg_dat_ptr); } pl_temp_alloc *saved_tmp = g_temp_alloc; pl_temp_alloc tmp = {0}; g_temp_alloc = &tmp; pl_program *prog = parse_program_src(rt_ctrl, dbg_dat_ptr, "", ""); if (!prog) { temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); g_temp_alloc = saved_tmp; return NULL; } for (size_t i = 0; i < count; i++) { const char *path = paths[i]; size_t n = 0; CHR *buf = flowlog_read_entire_file(path, &n); if (!buf) { temp_alloc_free_all(&tmp, rt_ctrl, dbg_dat_ptr); g_temp_alloc = saved_tmp; return NULL; } parse_program_src_into(prog, buf, path ? path : "", rt_ctrl, dbg_dat_ptr, 0); free(buf); } prog->wam_requires_interp = program_requires_interp_for_wam(prog); prog_index_build_locked(prog, rt_ctrl, dbg_dat_ptr); atomic_store_explicit( &prog->index_epoch, atomic_load_explicit(&prog->clause_epoch, memory_order_acquire), memory_order_release); prog->alloc_snapshot = temp_snapshot_from_temp_alloc(&tmp, rt_ctrl, dbg_dat_ptr); temp_alloc_drop_lists(&tmp); g_temp_alloc = saved_tmp; return prog; } static void flowlog_write_fd_mem(int fd, const char *s, size_t n) { if (fd < 0 || !s || !n) { return; } const char *p = s; size_t left = n; while (left) { const ssize_t w = write(fd, p, left); if (w < 0) { if (errno == EINTR) { continue; } break; } p += (size_t)w; left -= (size_t)w; } } static void flowlog_print_with_final_newline(const char *s) { if (!s) { return; } // Print via fd writes rather than stdio: signal interruptions can leave // FILE* streams in an error state and (flakily) drop subsequent REPL output. // Using `write(2)` with EINTR retry keeps output reliable under SIGINT/SIGINFO. const size_t n = strlen(s); flowlog_write_fd_mem(STDOUT_FILENO, s, n); if (!n || s[n - 1] != '\n') { flowlog_write_fd_mem(STDOUT_FILENO, "\n", 1); } } static void flowlog_write_stdout_mem(const char *s, size_t n) { flowlog_write_fd_mem(STDOUT_FILENO, s, n); } typedef struct { const pl_program *saved_prog; bool saved_local_alloc; pl_table_state *saved_table; pl_table_state *table; pl_parallel_state *saved_par; atomic_int *saved_budget; pl_parallel_state *par; pl_sbuf *saved_capture; bool saved_drain_ok; pl_temp_alloc tmp; } flowlog_query_session; static void flowlog_query_session_begin(flowlog_query_session *qs, pl_program *prog, pl_sbuf *capture, const ULO *dbg_dat_ptr) { if (!qs) { return; } flowlog_interrupt_clear(); memset(qs, 0, sizeof(*qs)); flowlog_trace_diag_reset_tls(); qs->saved_prog = g_current_prog; g_current_prog = prog; g_unify_occurs_check = prog ? prog->flag_occurs_check : false; g_halt_requested = false; g_halt_code = 0; streams_reset_for_query(dbg_dat_ptr); g_last_tc_cp_mask = 0; g_last_tc_worker_count = 0; g_last_tc_start_ok = 0; g_last_tc_start_err_code = 0; g_last_tc_start_err_text[0] = '\0'; qs->saved_local_alloc = g_pool_local_alloc; g_pool_local_alloc = flowlog_pool_local_alloc_enabled(); qs->tmp = (pl_temp_alloc){0}; g_temp_alloc = &qs->tmp; qs->saved_table = g_table_state; qs->table = NULL; if (prog && prog->tabled_pred_count) { qs->table = table_state_create(dbg_dat_ptr); g_table_state = qs->table; } qs->saved_par = g_par_state; qs->saved_budget = g_par_budget; qs->par = par_state_create((int)get_n_cpuproc()); g_par_state = qs->par ? qs->par : qs->saved_par; g_par_budget = qs->par ? &qs->par->budget : qs->saved_budget; qs->saved_capture = g_stdio_capture; g_stdio_capture = capture; qs->saved_drain_ok = g_stdio_capture_drain_ok; g_stdio_capture_drain_ok = true; } static void flowlog_query_session_end(flowlog_query_session *qs, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!qs) { return; } g_stdio_capture = qs->saved_capture; g_stdio_capture_drain_ok = qs->saved_drain_ok; // Signal delivery can leave stdio streams in EOF/error state (especially in // non-interactive mode where stdin/stdout are pipes). Clear them so the REPL // continues to accept input after an interrupt. clearerr(stdin); clearerr(stdout); clearerr(stderr); g_par_state = qs->saved_par; g_par_budget = qs->saved_budget; if (qs->par) { par_state_free_all(qs->par, rt_ctrl, dbg_dat_ptr); } g_table_state = qs->saved_table; if (qs->table) { table_state_free(qs->table, rt_ctrl, dbg_dat_ptr); } g_temp_alloc = NULL; temp_alloc_free_all(&qs->tmp, rt_ctrl, dbg_dat_ptr); flowlog_interrupt_clear(); g_current_prog = qs->saved_prog; g_pool_local_alloc = qs->saved_local_alloc; } static void flowlog_cut_signal_exception_to_sbuf(const pl_cut_signal *sig, pl_sbuf *sb, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!sig || !sb || !sig->except) { return; } pl_term *t0 = deref_term(sig->except_term, sig->except_env); const bool is_error = t0 && (t0->tag == PL_TERM_STRUCT) && (t0->v.str.arity == 2) && !strcmp(t0->v.str.functor, "error"); if (is_error) { term_to_sbuf(sig->except_term, sig->except_env, sb, dbg_dat_ptr); } else { pl_term *wrap = make_struct_rt(rt_ctrl, dbg_dat_ptr, "throw", 1); wrap->v.str.args[0] = sig->except_term; term_to_sbuf(wrap, sig->except_env, sb, dbg_dat_ptr); } } static bool flowlog_query_select_engine(pl_program *prog, const pl_query *q, pl_parallel_state *par) { const pl_engine_mode requested_engine = prog ? prog->flag_engine : PL_ENGINE_INTERP; const bool want_wam = (requested_engine == PL_ENGINE_WAM); const bool want_wamvm = (requested_engine == PL_ENGINE_WAMVM); const bool query_needs_interp = q && query_requires_interp_for_wam(q); const bool can_wam_family = (want_wam || want_wamvm) && prog && !prog->wam_requires_interp && !query_needs_interp; if (can_wam_family) { g_engine_active = requested_engine; } else { g_engine_active = PL_ENGINE_INTERP; } if (par) { par->engine_active = g_engine_active; } if ((want_wam || want_wamvm) && !can_wam_family) { bool warn = true; const char *e = getenv("FLOWLOG_WARN_ENGINE_FALLBACK"); if (e && *e) { warn = strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false"); } if (warn) { (void)fprintf(stderr, "flowlog: warning: WAM engine unavailable; falling back to interpreter"); const bool r_prog = (prog && prog->wam_requires_interp); const bool r_query = query_needs_interp; if (r_prog || r_query) { (void)fprintf(stderr, " (reason:"); if (r_prog) { (void)fprintf(stderr, " program_requires_interp_for_wam"); } if (r_query) { (void)fprintf(stderr, " query_requires_interp_for_wam"); } (void)fprintf(stderr, ")"); } (void)fprintf(stderr, "\n"); } } return can_wam_family; } static pl_cut_signal flowlog_query_solve(pl_program *prog, const pl_query *q, bool can_wam_family, bool stop_at_first, pl_sbuf *out, ULO *sol_count, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_env empty = {0}; int top_barrier = 0; int top_exc_barrier = 0; pl_wamvm_barrier top_wamvm_barrier = {.prev = NULL, .cp_base = 0}; if (can_wam_family && prog) { prog_index_ensure(prog, rt_ctrl, dbg_dat_ptr); pl_wam_state st = {0}; wam_trail_init(&st.trail); pl_wam_cell *q_cells = NULL; if (q && q->var_count) { q_cells = (pl_wam_cell *)pool_alloc(rt_ctrl, sizeof(*q_cells) * q->var_count, dbg_dat_ptr); memset(q_cells, 0, sizeof(*q_cells) * q->var_count); } if (q && q->scope) { wam_state_push_scope_with_cells(&st, (pl_scope *)q->scope, q_cells, q ? q->var_count : 0, rt_ctrl, dbg_dat_ptr); st.q_scope_id = ((pl_scope *)q->scope)->reserved; st.q_cells = q_cells; } pl_cut_signal r = cut_none(); if (g_engine_active == PL_ENGINE_WAMVM) { r = solve_goals_wamvm(prog, q, q && q->goal_count ? (pl_term *const *)&q->goals[1] : NULL, q ? q->goal_count : 0, &st, &top_wamvm_barrier, &top_exc_barrier, 0, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } else { r = solve_goals_wam(prog, q, q && q->goal_count ? (pl_term *const *)&q->goals[1] : NULL, q ? q->goal_count : 0, &st, &top_barrier, &top_exc_barrier, 0, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } wam_trail_free(&st.trail); free(st.scopes); st.scopes = NULL; st.scope_count = 0; st.scope_cap = 0; return r; } return solve_goals(prog, q, q && q->goal_count ? (pl_term *const *)&q->goals[1] : NULL, q ? q->goal_count : 0, &empty, &top_barrier, &top_exc_barrier, 0, stop_at_first, out, sol_count, rt_ctrl, dbg_dat_ptr); } static bool flowlog_run_init_goal(pl_program *prog, const pl_init_goal *ig, const void *rt_ctrl, const ULO *dbg_dat_ptr, int *out_exit_code) { if (out_exit_code) { *out_exit_code = 0; } if (!prog || !ig || !ig->goal) { return false; } pl_sbuf io; sbuf_init(&io, rt_ctrl, dbg_dat_ptr); flowlog_query_session qs; flowlog_query_session_begin(&qs, prog, &io, dbg_dat_ptr); pl_parse tmp_parse = {0}; tmp_parse.rt_ctrl = rt_ctrl; tmp_parse.dbg_dat_ptr = dbg_dat_ptr; pl_term **goals0 = NULL; ULO goal_count = 0; ULO goal_cap = 0; flatten_conjunction_goals(&tmp_parse, ig->goal, &goals0, &goal_count, &goal_cap); pl_query q = {0}; q.scope = ig->scope; q.var_count = ig->var_count; q.var_names = ig->var_names; q.goal_count = goal_count; if (goal_count) { q.goals = (pl_term **)pool_alloc(rt_ctrl, sizeof(pl_term *) * (goal_count + 1), dbg_dat_ptr); q.goals[0] = NULL; for (ULO j = 0; j < goal_count; j++) { q.goals[j + 1] = goals0[j]; } q.term = q.goals[1]; } else { q.goals = NULL; q.term = NULL; } const bool can_wam_family = flowlog_query_select_engine(prog, &q, qs.par); ULO sol_count = 0; pl_cut_signal r = flowlog_query_solve(prog, &q, can_wam_family, true, NULL, &sol_count, rt_ctrl, dbg_dat_ptr); if (io.buf && io.len) { flowlog_write_stdout_mem(io.buf, io.len); } int exit_code = 0; bool should_exit = false; const bool interrupted = flowlog_interrupted(); const bool halted = r.cut && (r.target == &g_halt_barrier); if (halted) { should_exit = true; exit_code = (int)g_halt_code; } else if (interrupted) { should_exit = true; exit_code = 130; } else if (r.except) { pl_sbuf err; sbuf_init(&err, rt_ctrl, dbg_dat_ptr); sbuf_append_cstr(&err, "flowlog: initialization exception"); if (ig->src_line) { sbuf_append_cstr(&err, " ("); sbuf_append_int(&err, (SLO)ig->src_line); sbuf_append_char(&err, ':'); sbuf_append_int(&err, (SLO)ig->src_col); sbuf_append_char(&err, ')'); } sbuf_append_cstr(&err, ": "); flowlog_cut_signal_exception_to_sbuf(&r, &err, rt_ctrl, dbg_dat_ptr); trace_print_stack(prog); (void)fprintf(stderr, "%s\n", err.buf ? err.buf : ""); sbuf_free(&err); should_exit = true; exit_code = 1; } else if (!sol_count) { pl_sbuf err; sbuf_init(&err, rt_ctrl, dbg_dat_ptr); sbuf_append_cstr(&err, "flowlog: initialization goal failed"); if (ig->src_line) { sbuf_append_cstr(&err, " ("); sbuf_append_int(&err, (SLO)ig->src_line); sbuf_append_char(&err, ':'); sbuf_append_int(&err, (SLO)ig->src_col); sbuf_append_char(&err, ')'); } sbuf_append_cstr(&err, ": "); pl_env empty = {0}; term_to_sbuf(ig->goal, &empty, &err, dbg_dat_ptr); (void)fprintf(stderr, "%s\n", err.buf ? err.buf : ""); sbuf_free(&err); should_exit = true; exit_code = 1; } sbuf_free(&io); flowlog_query_session_end(&qs, rt_ctrl, dbg_dat_ptr); if (should_exit && out_exit_code) { *out_exit_code = exit_code; } return should_exit; } static bool flowlog_run_init_goals(pl_program *prog, const void *rt_ctrl, const ULO *dbg_dat_ptr, int *out_exit_code) { if (out_exit_code) { *out_exit_code = 0; } if (!prog || !prog->init_goals || !prog->init_goal_count) { return false; } flowlog_program_use_default_argv(prog); for (ULO i = 1; i <= prog->init_goal_count; i++) { const pl_init_goal *ig = prog->init_goals[i]; if (!ig || !ig->goal) { continue; } (void)flowlog_program_use_src_argv(prog, ig->src_name, false); int code = 0; if (flowlog_run_init_goal(prog, ig, rt_ctrl, dbg_dat_ptr, &code)) { flowlog_program_use_default_argv(prog); if (out_exit_code) { *out_exit_code = code; } return true; } } flowlog_program_use_default_argv(prog); return false; } static bool flowlog_run_query(pl_program *prog, const char *qsrc, const void *rt_ctrl, const ULO *dbg_dat_ptr, int *out_halt_code) { if (out_halt_code) { *out_halt_code = 0; } flowlog_interrupt_clear(); if (!qsrc) { flowlog_print_with_final_newline("false"); return false; } if (!prog) { prog = flowlog_program_from_src("", "", rt_ctrl, dbg_dat_ptr); } pl_sbuf sb; sbuf_init(&sb, rt_ctrl, dbg_dat_ptr); flowlog_query_session qs; flowlog_query_session_begin(&qs, prog, &sb, dbg_dat_ptr); pl_query *q = parse_query_src(rt_ctrl, dbg_dat_ptr, prog, qsrc); const bool can_wam_family = flowlog_query_select_engine(prog, q, qs.par); ULO sol_count = 0; pl_cut_signal r = flowlog_query_solve(prog, q, can_wam_family, false, &sb, &sol_count, rt_ctrl, dbg_dat_ptr); const bool interrupted = flowlog_interrupted(); if (r.except) { trace_print_stack(prog); sbuf_clear(&sb); flowlog_cut_signal_exception_to_sbuf(&r, &sb, rt_ctrl, dbg_dat_ptr); } const bool halted = r.cut && (r.target == &g_halt_barrier); if (halted && out_halt_code) { *out_halt_code = (int)g_halt_code; } if (!interrupted && !r.except && !halted) { if (sol_count) { sbuf_append_char(&sb, '.'); } else { sbuf_append_cstr(&sb, " false."); } } flowlog_print_with_final_newline(sb.buf ? sb.buf : ""); sbuf_free(&sb); flowlog_query_session_end(&qs, rt_ctrl, dbg_dat_ptr); return halted; } typedef struct { char **items; size_t count; size_t cap; bool partial; } repl_solution_cache; static void repl_solution_cache_clear(repl_solution_cache *cache) { if (!cache) { return; } if (cache->items) { for (size_t i = 0; i < cache->count; i++) { free(cache->items[i]); cache->items[i] = NULL; } } free(cache->items); cache->items = NULL; cache->count = 0; cache->cap = 0; cache->partial = false; } static bool repl_solution_cache_push(repl_solution_cache *cache, const char *buf, size_t len) { if (!cache || !buf || !len) { return false; } if (cache->count == cache->cap) { size_t new_cap = cache->cap ? (cache->cap * 2) : 16; char **next = (char **)realloc(cache->items, sizeof(*next) * new_cap); if (!next) { return false; } cache->items = next; cache->cap = new_cap; } char *copy = (char *)malloc(len + 1); if (!copy) { return false; } memcpy(copy, buf, len); copy[len] = '\0'; cache->items[cache->count++] = copy; return true; } static void repl_solution_cache_replace(repl_solution_cache *dst, repl_solution_cache *src) { if (!dst || !src) { return; } repl_solution_cache_clear(dst); *dst = *src; src->items = NULL; src->count = 0; src->cap = 0; src->partial = false; } static void repl_print_solution_line(const char *text, bool first_line) { if (!text || !*text) { return; } if (first_line) { flowlog_write_stdout_mem(" ", sizeof(" ") - 1); } else { flowlog_write_stdout_mem("\n; ", sizeof("\n; ") - 1); } flowlog_write_stdout_mem(text, strlen(text)); } static void repl_print_cached_solutions(const repl_solution_cache *cache, bool force_partial) { const bool partial = force_partial || (cache && cache->partial); if (!cache || cache->count == 0) { if (partial) { flowlog_write_stdout_mem(" ... .\n", sizeof(" ... .\n") - 1); } else { flowlog_write_stdout_mem(" false.\n", sizeof(" false.\n") - 1); } return; } for (size_t i = 0; i < cache->count; i++) { repl_print_solution_line(cache->items[i], i == 0); } if (partial) { flowlog_write_stdout_mem("\n; ... .\n", sizeof("\n; ... .\n") - 1); } else { flowlog_write_stdout_mem(".\n", sizeof(".\n") - 1); } } static void repl_print_cached_solutions_all(const repl_solution_cache *cache) { repl_print_cached_solutions(cache, false); } static void repl_print_cached_solutions_so_far(const repl_solution_cache *cache) { if (!cache || cache->count == 0) { return; } flowlog_write_stdout_mem("\n", 1); repl_print_cached_solutions(cache, true); } typedef enum { REPL_SOLUTION_MORE, REPL_SOLUTION_ALL, REPL_SOLUTION_WRITE_FULL, REPL_SOLUTION_STOP, REPL_SOLUTION_NONE, REPL_SOLUTION_EOF, } repl_solution_action; typedef struct { pl_program *prog; char *qsrc; const void *rt_ctrl; const ULO *dbg_dat_ptr; pl_solution_stream *stream; atomic_int cancel; pl_cut_signal sig; bool halted; int halt_code; bool interrupted; ULO sol_count; char *exception_text; } flowlog_repl_query_ctx; static repl_solution_action repl_read_solution_action_timeout(int timeout_ms, bool *io_timed_out); static bool repl_handle_solution_action(pl_solution_stream *stream, flowlog_repl_query_ctx *ctx, repl_solution_cache *cache, repl_solution_action act, bool *io_auto_all, bool *io_searching_marker) { if (!stream || !ctx || !io_auto_all || !io_searching_marker) { return false; } if (act == REPL_SOLUTION_MORE) { *io_searching_marker = false; solution_stream_allow_more(stream, FLOWLOG_REPL_BATCH_SIZE); return false; } if (act == REPL_SOLUTION_ALL) { *io_searching_marker = false; *io_auto_all = true; solution_stream_allow_more(stream, FLOWLOG_REPL_BATCH_SIZE); return false; } if (act == REPL_SOLUTION_WRITE_FULL) { repl_print_cached_solutions_so_far(cache); return false; } if (act == REPL_SOLUTION_STOP || act == REPL_SOLUTION_EOF) { atomic_store_explicit(&ctx->cancel, 1, memory_order_relaxed); solution_stream_stop(stream); return true; } return false; } static void *flowlog_repl_query_worker(void *arg) { flowlog_repl_query_ctx *ctx = (flowlog_repl_query_ctx *)arg; if (!ctx) { return NULL; } setup_thread_safe_functionality_for_local_thread(); flowlog_cstack_init_once(); if (!ctx->stream || !ctx->qsrc) { if (ctx->stream) { solution_stream_mark_done(ctx->stream); } cleanup_thread_safe_functionality_for_local_thread(); return NULL; } flowlog_interrupt_clear(); pl_program *prog = ctx->prog; if (!prog) { prog = flowlog_program_from_src("", "", ctx->rt_ctrl, ctx->dbg_dat_ptr); } pl_sbuf sb; sbuf_init(&sb, ctx->rt_ctrl, ctx->dbg_dat_ptr); flowlog_query_session qs; flowlog_query_session_begin(&qs, prog, &sb, ctx->dbg_dat_ptr); pl_query *q = parse_query_src(ctx->rt_ctrl, ctx->dbg_dat_ptr, prog, ctx->qsrc); const bool can_wam_family = flowlog_query_select_engine(prog, q, qs.par); // Keep interactive toplevel enumeration predictable and permit-gated. const bool saved_par_or = prog ? prog->flag_parallel_or : false; const bool saved_par_and = prog ? prog->flag_parallel_and : false; if (prog) { prog->flag_parallel_or = false; prog->flag_parallel_and = false; } const uintptr_t saved_cancel_ptr = atomic_load_explicit(&g_query_cancel_ptr, memory_order_relaxed); const int saved_stream_active = atomic_load_explicit(&g_solution_stream_active, memory_order_relaxed); atomic_store_explicit(&g_query_cancel_ptr, (uintptr_t)&ctx->cancel, memory_order_release); atomic_store_explicit(&g_solution_stream_active, 1, memory_order_release); pl_solution_stream *saved_stream = g_solution_stream; pl_solution_capture *saved_capture = g_solution_capture; pl_solution_capture cap = { .out = &sb, .retain_output = false, .stream = ctx->stream, }; g_solution_stream = ctx->stream; g_solution_capture = ∩ ULO sol_count = 0; pl_cut_signal sig = flowlog_query_solve(prog, q, can_wam_family, false, &sb, &sol_count, ctx->rt_ctrl, ctx->dbg_dat_ptr); if (prog) { prog->flag_parallel_or = saved_par_or; prog->flag_parallel_and = saved_par_and; } g_solution_capture = saved_capture; g_solution_stream = saved_stream; atomic_store_explicit(&g_solution_stream_active, saved_stream_active, memory_order_release); atomic_store_explicit(&g_query_cancel_ptr, saved_cancel_ptr, memory_order_release); ctx->sig = sig; ctx->sol_count = sol_count; ctx->interrupted = flowlog_interrupted(); ctx->halted = sig.cut && (sig.target == &g_halt_barrier); ctx->halt_code = ctx->halted ? (int)g_halt_code : 0; if (sig.except) { trace_print_stack(prog); pl_sbuf err; sbuf_init(&err, ctx->rt_ctrl, ctx->dbg_dat_ptr); flowlog_cut_signal_exception_to_sbuf(&sig, &err, ctx->rt_ctrl, ctx->dbg_dat_ptr); ctx->exception_text = err.buf ? strdup(err.buf) : NULL; sbuf_free(&err); } if (!ctx->interrupted && !ctx->halted && !sig.except) { if (sb.len) { solution_stream_append_pending(ctx->stream, sb.buf, sb.len); } if (ctx->stream->pending_io.len) { (void)solution_stream_emit_output(ctx->stream, ctx->stream->pending_io.buf, ctx->stream->pending_io.len); sbuf_clear(&ctx->stream->pending_io); } } else { sbuf_clear(&ctx->stream->pending_io); } sbuf_free(&sb); flowlog_query_session_end(&qs, ctx->rt_ctrl, ctx->dbg_dat_ptr); solution_stream_mark_done(ctx->stream); cleanup_thread_safe_functionality_for_local_thread(); return NULL; } static void repl_print_final_dot(void) { flowlog_write_stdout_mem(".", 1); flowlog_write_stdout_mem("\n", 1); } static void repl_print_final_false(bool with_leading_newline) { if (with_leading_newline) { flowlog_write_stdout_mem("\n", 1); } flowlog_write_stdout_mem(" false.\n", sizeof(" false.\n") - 1); } static void repl_print_final_ellipsis(void) { flowlog_write_stdout_mem("\n; ... .\n", sizeof("\n; ... .\n") - 1); } static bool repl_is_var_start_char(char c) { return (c == '_') || (c >= 'A' && c <= 'Z'); } static bool repl_is_var_char(char c) { return repl_is_var_start_char(c) || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9'); } static size_t repl_emit_solution_text(const char *ptr, size_t n, bool *io_saw_solution) { if (!ptr || n == 0) { return 0; } size_t emitted = 0; size_t start = 0; size_t last_non_space = (size_t)-1; int depth_paren = 0; int depth_brack = 0; int depth_brace = 0; char quote = '\0'; bool esc = false; for (size_t i = 0; i < n; i++) { const char c = ptr[i]; if (quote) { if (esc) { esc = false; } else if (c == '\\') { esc = true; } else if (c == quote) { quote = '\0'; } continue; } if (c == '\'' || c == '"') { quote = c; continue; } if (c == '(') { depth_paren++; } else if (c == ')' && depth_paren > 0) { depth_paren--; } else if (c == '[') { depth_brack++; } else if (c == ']' && depth_brack > 0) { depth_brack--; } else if (c == '{') { depth_brace++; } else if (c == '}' && depth_brace > 0) { depth_brace--; } if (depth_paren == 0 && depth_brack == 0 && depth_brace == 0 && repl_is_var_start_char(c)) { size_t j = i + 1; while (j < n && repl_is_var_char(ptr[j])) { j++; } if (j + 2 < n && ptr[j] == ' ' && ptr[j + 1] == '=' && ptr[j + 2] == ' ') { if (last_non_space != (size_t)-1 && ptr[last_non_space] != ',') { size_t seg_start = start; size_t seg_len = i - start; while (seg_len > 0 && (ptr[seg_start] == ' ' || ptr[seg_start] == '\t')) { seg_start++; seg_len--; } while (seg_len > 0 && (ptr[seg_start + seg_len - 1] == ' ' || ptr[seg_start + seg_len - 1] == '\t')) { seg_len--; } if (seg_len > 0) { if (io_saw_solution && *io_saw_solution) { flowlog_write_stdout_mem("\n; ", sizeof("\n; ") - 1); } else { flowlog_write_stdout_mem(" ", sizeof(" ") - 1); } flowlog_write_stdout_mem(ptr + seg_start, seg_len); if (io_saw_solution) { *io_saw_solution = true; } emitted++; } start = i; } } } if (c != ' ' && c != '\t') { last_non_space = i; } } size_t seg_start = start; size_t seg_len = n - start; while (seg_len > 0 && (ptr[seg_start] == ' ' || ptr[seg_start] == '\t')) { seg_start++; seg_len--; } while (seg_len > 0 && (ptr[seg_start + seg_len - 1] == ' ' || ptr[seg_start + seg_len - 1] == '\t')) { seg_len--; } if (seg_len > 0) { if (io_saw_solution && *io_saw_solution) { flowlog_write_stdout_mem("\n; ", sizeof("\n; ") - 1); } else { flowlog_write_stdout_mem(" ", sizeof(" ") - 1); } flowlog_write_stdout_mem(ptr + seg_start, seg_len); if (io_saw_solution) { *io_saw_solution = true; } emitted++; } return emitted; } static size_t repl_emit_solution_segment(const char *ptr, size_t n, bool *io_saw_solution) { if (!ptr || !n) { return 0; } size_t emitted = 0; const char *line = ptr; size_t line_len = 0; for (size_t i = 0; i <= n; i++) { if (i == n || ptr[i] == '\n' || ptr[i] == '\r') { line = ptr + (i - line_len); size_t ln = line_len; while (ln > 0) { if (ln >= 3 && line[0] == ';' && line[1] == ' ' && line[2] == ' ') { line += 3; ln -= 3; continue; } if (ln >= 3 && line[0] == ' ' && line[1] == ' ' && line[2] == ' ') { line += 3; ln -= 3; continue; } if (line[0] == '\n' || line[0] == '\r') { line++; ln--; continue; } break; } if (ln > 0) { emitted += repl_emit_solution_text(line, ln, io_saw_solution); } line_len = 0; continue; } line_len++; } return emitted; } static size_t repl_emit_solution_item(const pl_solution_item *item, bool *io_saw_solution) { if (!item || !item->buf || !item->len) { return 0; } return repl_emit_solution_segment(item->buf, item->len, io_saw_solution); } static bool flowlog_run_query_repl(pl_program *prog, const char *qsrc, bool tty, const void *rt_ctrl, const ULO *dbg_dat_ptr, repl_solution_cache *last_cache, int *out_halt_code) { if (out_halt_code) { *out_halt_code = 0; } if (!qsrc) { flowlog_print_with_final_newline("false"); if (last_cache) { repl_solution_cache_clear(last_cache); } return false; } repl_solution_cache query_cache = {0}; pl_solution_stream stream = {0}; if (!solution_stream_init(&stream, FLOWLOG_REPL_SOLUTION_QUEUE_CAP, rt_ctrl, dbg_dat_ptr)) { repl_solution_cache_clear(&query_cache); if (last_cache) { repl_solution_cache_clear(last_cache); } return flowlog_run_query(prog, qsrc, rt_ctrl, dbg_dat_ptr, out_halt_code); } flowlog_repl_query_ctx ctx = { .prog = prog, .qsrc = strdup(qsrc), .rt_ctrl = rt_ctrl, .dbg_dat_ptr = dbg_dat_ptr, .stream = &stream, .sig = cut_none(), .halted = false, .halt_code = 0, .interrupted = false, .sol_count = 0, .exception_text = NULL, }; atomic_init(&ctx.cancel, 0); if (!ctx.qsrc) { solution_stream_free(&stream); (void)fprintf(stderr, "flowlog: out of memory\n"); return false; } pthread_t thr; const int spawn_rc = pthread_create(&thr, NULL, flowlog_repl_query_worker, &ctx); if (spawn_rc != 0) { free(ctx.qsrc); solution_stream_free(&stream); repl_solution_cache_clear(&query_cache); if (last_cache) { repl_solution_cache_clear(last_cache); } return flowlog_run_query(prog, qsrc, rt_ctrl, dbg_dat_ptr, out_halt_code); } bool saw_solution = false; bool stopped_early = false; bool streaming_mode = !tty; bool auto_all = false; bool searching_marker = false; if (streaming_mode) { solution_stream_enable_streaming(&stream); } pl_solution_item item = {0}; while (true) { if (!streaming_mode && tty && !solution_stream_can_deliver(&stream)) { const repl_solution_action act = repl_read_solution_action_timeout(-1, NULL); if (repl_handle_solution_action(&stream, &ctx, &query_cache, act, &auto_all, &searching_marker)) { stopped_early = true; break; } continue; } bool timed_out = false; const bool popped = (!streaming_mode && tty) ? solution_stream_pop_timeout(&stream, &item, FLOWLOG_REPL_STREAM_POLL_MS, &timed_out) : solution_stream_pop(&stream, &item); if (!popped) { if (!streaming_mode && tty && timed_out) { const repl_solution_action act = repl_read_solution_action_timeout(0, NULL); if (repl_handle_solution_action(&stream, &ctx, &query_cache, act, &auto_all, &searching_marker)) { stopped_early = true; break; } if (!searching_marker && saw_solution && solution_stream_is_searching(&stream)) { flowlog_write_stdout_mem("\n;", sizeof("\n;") - 1); searching_marker = true; } continue; } break; } searching_marker = false; if (!item.has_solution) { if (item.buf && item.len) { if (auto_all) { size_t emitted = repl_emit_solution_segment(item.buf, item.len, &saw_solution); if (emitted == 0) { flowlog_write_stdout_mem(item.buf, item.len); } } else { flowlog_write_stdout_mem(item.buf, item.len); } } free(item.buf); item.buf = NULL; continue; } if (item.buf && item.len) { (void)repl_solution_cache_push(&query_cache, item.buf, item.len); } size_t emitted = repl_emit_solution_item(&item, &saw_solution); if (emitted == 0) { emitted = 1; if (!saw_solution) { saw_solution = true; } } free(item.buf); item.buf = NULL; solution_stream_ack_solutions(&stream, emitted); if (!streaming_mode && tty) { solution_stream_consume_permit_n(&stream, emitted); } if (auto_all && tty && !streaming_mode) { solution_stream_allow_more(&stream, emitted); } } (void)pthread_join(thr, NULL); free(ctx.qsrc); ctx.qsrc = NULL; if (ctx.halted && out_halt_code) { *out_halt_code = ctx.halt_code; } query_cache.partial = stopped_early || ctx.interrupted; if (last_cache) { repl_solution_cache_replace(last_cache, &query_cache); } else { repl_solution_cache_clear(&query_cache); } if (!stopped_early && !ctx.interrupted && !ctx.halted && ctx.sig.except) { if (ctx.exception_text) { flowlog_print_with_final_newline(ctx.exception_text); } else { flowlog_print_with_final_newline("throw(_)"); } } if (!ctx.interrupted && !ctx.halted && !ctx.sig.except) { if (stopped_early) { repl_print_final_ellipsis(); } else if (!saw_solution) { repl_print_final_false(false); } else { repl_print_final_dot(); } } solution_stream_free(&stream); free(ctx.exception_text); return ctx.halted; } /* --- SUBSECTION 26.2: REPL History & Line Editing ------------------------ */ // REPL history and line-editing support. // repl_history_init()/repl_history_add()/repl_history_push_mem() manage history file and in-memory ring. typedef struct { bool enabled; CHR *path; CHR **items; size_t count; size_t cap; } pl_repl_history; static void repl_history_free(pl_repl_history *h) { if (!h) { return; } for (size_t i = 0; i < h->count; i++) { free(h->items[i]); h->items[i] = NULL; } free(h->items); h->items = NULL; h->count = 0; h->cap = 0; free(h->path); h->path = NULL; h->enabled = false; } static CHR *flowlog_default_home_path(const char *env_name, const char *suffix) { if (!suffix || !*suffix) { return NULL; } const char *e = (env_name && *env_name) ? getenv(env_name) : NULL; if (e && *e) { return strdup(e); } const char *home = getenv("HOME"); if (!home || !*home) { return NULL; } const size_t n = strlen(home); const size_t m = strlen(suffix); CHR *p = (CHR *)malloc(n + m + 1); if (!p) { return NULL; } memcpy(p, home, n); memcpy(p + n, suffix, m + 1); return p; } static CHR *flowlog_rc_default_path(void) { return flowlog_default_home_path("FLOWLOG_RC_FILE", FLOWLOG_RC_DEFAULT_SUFFIX); } static CHR *repl_history_default_path(void) { return flowlog_default_home_path("FLOWLOG_HISTORY_FILE", FLOWLOG_HISTORY_DEFAULT_SUFFIX); } static void repl_history_push_mem(pl_repl_history *h, const CHR *line) { if (!h || !line || !*line) { return; } if (h->count && h->items[h->count - 1] && !strcmp(h->items[h->count - 1], line)) { return; } if (h->count == h->cap) { size_t new_cap = h->cap ? (h->cap * 2) : (size_t)FLOWLOG_HISTORY_INITIAL_CAP; CHR **nitems = (CHR **)realloc(h->items, new_cap * sizeof(*nitems)); if (!nitems) { return; } h->items = nitems; h->cap = new_cap; } h->items[h->count++] = strdup(line); } static void repl_history_add(pl_repl_history *h, const CHR *line) { if (!h || !h->enabled || !line || !*line) { return; } repl_history_push_mem(h, line); if (!h->path || !*h->path) { return; } FILE *fp = fopen(h->path, "a"); if (!fp) { return; } (void)fputs(line, fp); (void)fputc('\n', fp); (void)fclose(fp); } static void repl_history_init(pl_repl_history *h, bool enable) { if (!h) { return; } memset(h, 0, sizeof(*h)); h->enabled = enable; if (!enable) { return; } h->path = repl_history_default_path(); if (!h->path || !*h->path) { h->enabled = false; return; } FILE *fp = fopen(h->path, "r"); if (!fp) { return; } CHR *line = NULL; size_t cap = 0; for (;;) { ssize_t n = getline(&line, &cap, fp); if (n < 0) { break; } while (n > 0 && (line[n - 1] == '\n' || line[n - 1] == '\r')) { line[--n] = '\0'; } if (n > 0) { repl_history_push_mem(h, line); } } free(line); (void)fclose(fp); } static CHR *repl_history_normalize(const CHR *s, size_t n) { if (!s || !n) { return NULL; } pl_sbuf sb; sbuf_init(&sb, NULL, NULL); bool in_space = true; // trim leading ws for (size_t i = 0; i < n; i++) { const unsigned char c = (unsigned char)s[i]; if (isspace(c)) { in_space = true; continue; } if (in_space && sb.len) { sbuf_append_char(&sb, ' '); } in_space = false; sbuf_append_char(&sb, (char)c); } if (!sb.len) { sbuf_free(&sb); return NULL; } // sb.buf is heap-allocated; transfer ownership. CHR *out = sb.buf; sb.buf = NULL; sbuf_free(&sb); return out; } typedef struct { struct termios orig; bool active; } pl_repl_term_state; static bool repl_term_raw_enable(pl_repl_term_state *st) { if (!st) { return false; } memset(st, 0, sizeof(*st)); if (tcgetattr(STDIN_FILENO, &st->orig) != 0) { return false; } struct termios raw = st->orig; raw.c_iflag &= (tcflag_t) ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON); // Keep output post-processing enabled so '\n' returns to column 0 (CRLF) while // we're in raw input mode; otherwise multi-line output (e.g. Ctrl-T SIGINFO) // "staircases" to the right. raw.c_oflag |= (tcflag_t)(OPOST); #ifdef ONLCR raw.c_oflag |= (tcflag_t)(ONLCR); #endif raw.c_cflag |= (tcflag_t)(CS8); raw.c_lflag &= (tcflag_t) ~(ECHO | ICANON | IEXTEN | ISIG); raw.c_cc[VMIN] = 1; raw.c_cc[VTIME] = 0; if (tcsetattr(STDIN_FILENO, TCSAFLUSH, &raw) != 0) { return false; } st->active = true; return true; } static void repl_term_raw_disable(pl_repl_term_state *st) { if (!st || !st->active) { return; } (void)tcsetattr(STDIN_FILENO, TCSAFLUSH, &st->orig); st->active = false; } static repl_solution_action repl_solution_action_from_char(int c) { if (c == EOF) { return REPL_SOLUTION_EOF; } if (c == ' ' || c == ';' || c == 'n' || c == 'N') { return REPL_SOLUTION_MORE; } if (c == 'a' || c == 'A') { return REPL_SOLUTION_ALL; } if (c == 'w' || c == 'W' || c == 'x' || c == 'X') { return REPL_SOLUTION_WRITE_FULL; } if (c == '.' || c == '\n' || c == '\r') { return REPL_SOLUTION_STOP; } return REPL_SOLUTION_NONE; } static repl_solution_action repl_read_solution_action_timeout(int timeout_ms, bool *io_timed_out) { if (io_timed_out) { *io_timed_out = false; } pl_repl_term_state ts = {0}; const bool raw = repl_term_raw_enable(&ts); if (timeout_ms >= 0) { fd_set rfds; FD_ZERO(&rfds); FD_SET(STDIN_FILENO, &rfds); struct timeval tv; tv.tv_sec = timeout_ms / 1000; tv.tv_usec = (timeout_ms % 1000) * 1000; int rc = -1; do { rc = select(STDIN_FILENO + 1, &rfds, NULL, NULL, &tv); } while (rc < 0 && errno == EINTR); if (rc == 0) { if (raw) { repl_term_raw_disable(&ts); } if (io_timed_out) { *io_timed_out = true; } return REPL_SOLUTION_NONE; } if (rc < 0 || !FD_ISSET(STDIN_FILENO, &rfds)) { if (raw) { repl_term_raw_disable(&ts); } return REPL_SOLUTION_EOF; } } unsigned char ch = 0; ssize_t nread = -1; do { nread = read(STDIN_FILENO, &ch, 1); } while (nread < 0 && errno == EINTR); if (raw) { repl_term_raw_disable(&ts); } if (nread <= 0) { if (nread < 0 && (errno == EAGAIN || errno == EWOULDBLOCK)) { if (io_timed_out) { *io_timed_out = true; } return REPL_SOLUTION_NONE; } return REPL_SOLUTION_EOF; } return repl_solution_action_from_char((int)ch); } static void repl_redraw_line(const char *prompt, const pl_sbuf *buf, size_t pos) { if (!prompt) { prompt = ""; } const size_t plen = strlen(prompt); (void)fputc('\r', stdout); (void)fputs(prompt, stdout); if (buf && buf->buf && buf->len) { (void)fwrite(buf->buf, 1, buf->len, stdout); } (void)fputs("\x1b[K", stdout); // clear to end of line (void)fputc('\r', stdout); if (plen + pos) { (void)fprintf(stdout, "\x1b[%zuC", plen + pos); } (void)fflush(stdout); } static void repl_buf_insert(pl_sbuf *buf, size_t *pos, char c) { if (!buf || !pos) { return; } sbuf_reserve(buf, 1); if (!buf->buf) { return; } if (*pos > buf->len) { *pos = buf->len; } memmove(buf->buf + *pos + 1, buf->buf + *pos, (buf->len - *pos) + 1); buf->buf[*pos] = c; buf->len++; (*pos)++; } static void repl_buf_delete_before(pl_sbuf *buf, size_t *pos) { if (!buf || !pos || !buf->buf || !buf->len || *pos == 0) { return; } if (*pos > buf->len) { *pos = buf->len; } memmove(buf->buf + *pos - 1, buf->buf + *pos, (buf->len - *pos) + 1); buf->len--; (*pos)--; } static void repl_buf_delete_at(pl_sbuf *buf, size_t pos) { if (!buf || !buf->buf || !buf->len || pos >= buf->len) { return; } memmove(buf->buf + pos, buf->buf + pos + 1, (buf->len - pos)); buf->len--; } static void repl_buf_set(pl_sbuf *buf, size_t *pos, const CHR *s) { if (!buf || !pos) { return; } sbuf_clear(buf); if (s && *s) { sbuf_append_cstr(buf, s); } *pos = buf->len; } typedef enum { FLOWLOG_REPL_READ_OK = 0, FLOWLOG_REPL_READ_EOF = 1, FLOWLOG_REPL_READ_INTERRUPT = 2, } flowlog_repl_read_status; static flowlog_repl_read_status repl_read_line_stdio(pl_sbuf *out) { if (!out) { return FLOWLOG_REPL_READ_EOF; } sbuf_clear(out); for (;;) { errno = 0; const int c = fgetc(stdin); if (c == EOF) { if (feof(stdin)) { return out->len ? FLOWLOG_REPL_READ_OK : FLOWLOG_REPL_READ_EOF; } if (ferror(stdin)) { const bool intr = (errno == EINTR) || flowlog_interrupted(); if (intr) { // On SIGINT, stdio may surface EINTR in the middle of a read. Clear the // error and retry so we don't drop already-buffered input. flowlog_interrupt_clear(); clearerr(stdin); continue; } clearerr(stdin); return out->len ? FLOWLOG_REPL_READ_OK : FLOWLOG_REPL_READ_EOF; } return out->len ? FLOWLOG_REPL_READ_OK : FLOWLOG_REPL_READ_EOF; } if (c == '\n') { break; } if (c == '\r') { // Treat CRLF as a single newline; keep it tolerant for Windows-style input. errno = 0; const int c2 = fgetc(stdin); if (c2 != '\n' && c2 != EOF) { ungetc(c2, stdin); } else if (c2 == EOF && ferror(stdin) && ((errno == EINTR) || flowlog_interrupted())) { flowlog_interrupt_clear(); clearerr(stdin); } break; } sbuf_append_char(out, (char)c); } return FLOWLOG_REPL_READ_OK; } static flowlog_repl_read_status repl_read_line_edit( const char *prompt, pl_sbuf *out, pl_repl_history *hist, bool history_enabled, const repl_solution_cache *expand_cache) { if (!out) { return FLOWLOG_REPL_READ_EOF; } sbuf_clear(out); pl_repl_term_state ts = {0}; if (!repl_term_raw_enable(&ts)) { (void)fputs(prompt ? prompt : "", stdout); (void)fflush(stdout); char *line = NULL; size_t cap = 0; ssize_t n = -1; do { errno = 0; n = getline(&line, &cap, stdin); if (n < 0 && errno == EINTR) { flowlog_interrupt_clear(); clearerr(stdin); (void)fputc('\n', stdout); (void)fflush(stdout); sbuf_clear(out); free(line); return FLOWLOG_REPL_READ_INTERRUPT; } } while (n < 0 && errno == EINTR); if (n < 0) { free(line); return FLOWLOG_REPL_READ_EOF; } while (n > 0 && (line[n - 1] == '\n' || line[n - 1] == '\r')) { line[--n] = '\0'; } sbuf_append_mem(out, line, (size_t)n); free(line); return FLOWLOG_REPL_READ_OK; } size_t pos = 0; long hist_idx = (hist && history_enabled) ? (long)hist->count : 0; CHR *scratch = NULL; repl_redraw_line(prompt, out, pos); for (;;) { unsigned char c = 0; ssize_t nread = read(STDIN_FILENO, &c, 1); if (nread <= 0) { repl_term_raw_disable(&ts); free(scratch); return FLOWLOG_REPL_READ_EOF; } // Ctrl-C: interrupt current input line. if (c == 0x03) { flowlog_interrupt_clear(); repl_term_raw_disable(&ts); free(scratch); (void)fputc('\n', stdout); (void)fflush(stdout); sbuf_clear(out); return FLOWLOG_REPL_READ_INTERRUPT; } // Ctrl-T (BSD SIGINFO): show a live status report. if (c == 0x14) { flowlog_siginfo_report(); repl_redraw_line(prompt, out, pos); continue; } if (c == '\r' || c == '\n') { (void)fputc('\n', stdout); (void)fflush(stdout); break; } // Ctrl-D: EOF on empty line, otherwise delete at cursor. if (c == 0x04) { if (!out->len) { repl_term_raw_disable(&ts); free(scratch); return FLOWLOG_REPL_READ_EOF; } repl_buf_delete_at(out, pos); repl_redraw_line(prompt, out, pos); continue; } // Backspace / DEL. if (c == 0x7f || c == 0x08) { repl_buf_delete_before(out, &pos); repl_redraw_line(prompt, out, pos); continue; } // Ctrl-A / Ctrl-E: home/end. if (c == 0x01) { pos = 0; repl_redraw_line(prompt, out, pos); continue; } if (c == 0x05) { pos = out->len; repl_redraw_line(prompt, out, pos); continue; } // Ctrl-B / Ctrl-F: left/right. if (c == 0x02) { if (pos > 0) { pos--; } repl_redraw_line(prompt, out, pos); continue; } if (c == 0x06) { if (pos < out->len) { pos++; } repl_redraw_line(prompt, out, pos); continue; } // Ctrl-X: print full saved solutions from previous query without losing input. if (c == 0x18) { (void)fputc('\n', stdout); (void)fflush(stdout); repl_print_cached_solutions_all(expand_cache); repl_redraw_line(prompt, out, pos); continue; } // Ctrl-K: kill to end of line. if (c == 0x0b) { if (pos < out->len && out->buf) { out->buf[pos] = '\0'; out->len = pos; } repl_redraw_line(prompt, out, pos); continue; } // Ctrl-U: kill to start of line. if (c == 0x15) { if (pos && out->buf) { memmove(out->buf, out->buf + pos, (out->len - pos) + 1); out->len -= pos; pos = 0; } repl_redraw_line(prompt, out, pos); continue; } // Ctrl-L: clear screen. if (c == 0x0c) { (void)fputs("\x1b[2J\x1b[H", stdout); repl_redraw_line(prompt, out, pos); continue; } // Ctrl-P / Ctrl-N: history previous/next. if ((c == 0x10 || c == 0x0e) && hist && history_enabled && hist->count) { if (!scratch) { scratch = strdup(out->buf ? out->buf : ""); } if (c == 0x10) { if (hist_idx > 0) { hist_idx--; repl_buf_set(out, &pos, hist->items[hist_idx]); } } else { if (hist_idx < (long)hist->count) { hist_idx++; } if (hist_idx >= (long)hist->count) { repl_buf_set(out, &pos, scratch ? scratch : ""); free(scratch); scratch = NULL; hist_idx = (long)hist->count; } else { repl_buf_set(out, &pos, hist->items[hist_idx]); } } repl_redraw_line(prompt, out, pos); continue; } // Escape sequences (arrows, delete, home/end). if (c == 0x1b) { unsigned char a = 0; if (read(STDIN_FILENO, &a, 1) <= 0) { continue; } if (a == '[') { unsigned char b = 0; if (read(STDIN_FILENO, &b, 1) <= 0) { continue; } if (b == 'A' || b == 'B') { // up/down -> history const unsigned char code = (b == 'A') ? 0x10 : 0x0e; if (hist && history_enabled && hist->count) { if (!scratch) { scratch = strdup(out->buf ? out->buf : ""); } if (code == 0x10) { if (hist_idx > 0) { hist_idx--; repl_buf_set(out, &pos, hist->items[hist_idx]); } } else { if (hist_idx < (long)hist->count) { hist_idx++; } if (hist_idx >= (long)hist->count) { repl_buf_set(out, &pos, scratch ? scratch : ""); free(scratch); scratch = NULL; hist_idx = (long)hist->count; } else { repl_buf_set(out, &pos, hist->items[hist_idx]); } } repl_redraw_line(prompt, out, pos); } continue; } if (b == 'C') { if (pos < out->len) { pos++; repl_redraw_line(prompt, out, pos); } continue; } if (b == 'D') { if (pos > 0) { pos--; repl_redraw_line(prompt, out, pos); } continue; } if (b == 'H') { pos = 0; repl_redraw_line(prompt, out, pos); continue; } if (b == 'F') { pos = out->len; repl_redraw_line(prompt, out, pos); continue; } if (b == '3') { unsigned char t = 0; if (read(STDIN_FILENO, &t, 1) > 0 && t == '~') { repl_buf_delete_at(out, pos); repl_redraw_line(prompt, out, pos); } continue; } } else if (a == 'O') { unsigned char b = 0; if (read(STDIN_FILENO, &b, 1) <= 0) { continue; } if (b == 'H') { pos = 0; repl_redraw_line(prompt, out, pos); continue; } if (b == 'F') { pos = out->len; repl_redraw_line(prompt, out, pos); continue; } } continue; } // Regular characters. if (c >= 0x20 && c != 0x7f) { repl_buf_insert(out, &pos, (char)c); repl_redraw_line(prompt, out, pos); continue; } } repl_term_raw_disable(&ts); free(scratch); return FLOWLOG_REPL_READ_OK; } static bool flowlog_repl_read_sentence(pl_sbuf *sb, pl_repl_history *hist, const repl_solution_cache *expand_cache) { if (!sb) { return false; } sbuf_clear(sb); const bool tty = (hist && hist->enabled); for (;;) { const char *prompt = sb->len ? "| " : "?- "; const bool history_enabled = (sb->len == 0); pl_sbuf line; sbuf_init(&line, sb->rt_ctrl, sb->dbg_dat_ptr); flowlog_repl_read_status st = FLOWLOG_REPL_READ_EOF; if (tty) { st = repl_read_line_edit(prompt, &line, hist, history_enabled, expand_cache); } else { st = repl_read_line_stdio(&line); } if (st == FLOWLOG_REPL_READ_EOF) { sbuf_free(&line); return false; } if (st == FLOWLOG_REPL_READ_INTERRUPT) { sbuf_free(&line); sbuf_clear(sb); continue; } // Wrapper commands (":load", ":reload", ":help") are single-line and do not require a trailing '.'. if (!sb->len) { const char *t = line.buf ? line.buf : ""; while (*t && isspace((unsigned char)*t)) { t++; } if (*t == ':') { sbuf_append_mem(sb, line.buf ? line.buf : "", line.len); sbuf_append_char(sb, '\n'); sbuf_free(&line); return true; } } sbuf_append_mem(sb, line.buf ? line.buf : "", line.len); sbuf_append_char(sb, '\n'); sbuf_free(&line); // End when the last non-whitespace char is '.' size_t i = sb->len; while (i > 0 && isspace((unsigned char)sb->buf[i - 1])) { i--; } if (i > 0 && sb->buf[i - 1] == '.') { if (tty) { CHR *norm = repl_history_normalize(sb->buf, sb->len); if (norm) { repl_history_add(hist, norm); free(norm); } } return true; } } } typedef struct { char **items; size_t count; size_t cap; } flowlog_strvec; typedef struct { char *path; flowlog_strvec argv; } flowlog_file_arg_segment; typedef struct { flowlog_file_arg_segment *items; size_t count; size_t cap; } flowlog_file_arg_segments; static void flowlog_strvec_free(flowlog_strvec *v) { if (!v) { return; } if (v->items) { for (size_t i = 0; i < v->count; i++) { free(v->items[i]); v->items[i] = NULL; } } free(v->items); v->items = NULL; v->count = 0; v->cap = 0; } static bool flowlog_strvec_push(flowlog_strvec *v, char *s) { if (!v || !s) { free(s); return false; } if (v->count == v->cap) { size_t new_cap = v->cap ? v->cap * 2 : 8; char **ni = (char **)realloc(v->items, new_cap * sizeof(char *)); if (!ni) { free(s); return false; } v->items = ni; v->cap = new_cap; } v->items[v->count++] = s; return true; } static bool flowlog_strvec_push_dup(flowlog_strvec *v, const char *s) { return flowlog_strvec_push(v, strdup(s ? s : "")); } static void flowlog_file_arg_segments_free(flowlog_file_arg_segments *v) { if (!v) { return; } if (v->items) { for (size_t i = 0; i < v->count; i++) { free(v->items[i].path); v->items[i].path = NULL; flowlog_strvec_free(&v->items[i].argv); } } free(v->items); v->items = NULL; v->count = 0; v->cap = 0; } static bool flowlog_file_arg_segments_push_file(flowlog_file_arg_segments *v, char *path) { if (!v || !path) { free(path); return false; } if (v->count == v->cap) { size_t new_cap = v->cap ? v->cap * 2 : 4; flowlog_file_arg_segment *ni = (flowlog_file_arg_segment *)realloc(v->items, new_cap * sizeof(flowlog_file_arg_segment)); if (!ni) { free(path); return false; } memset(ni + v->cap, 0, (new_cap - v->cap) * sizeof(flowlog_file_arg_segment)); v->items = ni; v->cap = new_cap; } flowlog_file_arg_segment *seg = &v->items[v->count++]; memset(seg, 0, sizeof(*seg)); seg->path = path; return true; } static bool flowlog_file_arg_segments_push_arg(flowlog_file_arg_segments *v, char *arg) { if (!v || !arg || !v->count) { free(arg); return false; } return flowlog_strvec_push(&v->items[v->count - 1].argv, arg); } static bool flowlog_file_arg_segments_push_file_dup(flowlog_file_arg_segments *v, const char *path) { return flowlog_file_arg_segments_push_file(v, strdup(path ? path : "")); } static bool flowlog_file_arg_segments_push_arg_dup(flowlog_file_arg_segments *v, const char *arg) { return flowlog_file_arg_segments_push_arg(v, strdup(arg ? arg : "")); } static void flowlog_cli_parse_state_free(flowlog_strvec *system_files, flowlog_file_arg_segments *positional_segments) { if (system_files) { flowlog_strvec_free(system_files); } if (positional_segments) { flowlog_file_arg_segments_free(positional_segments); } } static int flowlog_cli_fail_oom(flowlog_strvec *system_files, flowlog_file_arg_segments *positional_segments) { flowlog_cli_parse_state_free(system_files, positional_segments); (void)fprintf(stderr, "flowlog: out of memory\n"); return 1; } static int flowlog_cli_fail_requires_arg( flowlog_strvec *system_files, flowlog_file_arg_segments *positional_segments, const char *opt) { (void)fprintf(stderr, "flowlog: %s requires an argument\n", opt ? opt : "option"); flowlog_usage(stderr); flowlog_cli_parse_state_free(system_files, positional_segments); return 2; } static int flowlog_cli_fail_requires_file( flowlog_strvec *system_files, flowlog_file_arg_segments *positional_segments, const char *opt) { (void)fprintf(stderr, "flowlog: %s requires a file path\n", opt ? opt : "option"); flowlog_usage(stderr); flowlog_cli_parse_state_free(system_files, positional_segments); return 2; } static char *flowlog_format_consult_spec(const char *const *paths, size_t count) { if (!paths || !count) { return NULL; } pl_sbuf sb; sbuf_init(&sb, NULL, NULL); sbuf_append_char(&sb, '['); for (size_t i = 0; i < count; i++) { if (i) { sbuf_append_char(&sb, ','); } sbuf_append_char(&sb, '\''); const char *p = paths[i] ? paths[i] : ""; while (*p) { if (*p == '\'') { sbuf_append_mem(&sb, "''", 2); } else { sbuf_append_char(&sb, *p); } p++; } sbuf_append_char(&sb, '\''); } sbuf_append_char(&sb, ']'); char *out = sb.buf; sb.buf = NULL; sbuf_free(&sb); return out; } static bool flowlog_fs_is_regular_file(const char *path) { if (!path || !*path) { return false; } struct stat st; if (stat(path, &st) != 0) { return false; } return S_ISREG(st.st_mode); } static char *flowlog_resolve_program_path(const char *spec) { if (!spec || !*spec) { return NULL; } if (flowlog_fs_is_regular_file(spec)) { return strdup(spec); } // Try "foo.pl" when "foo" is missing (common Prolog consult behavior). const char *last_slash = strrchr(spec, '/'); const char *base = last_slash ? (last_slash + 1) : spec; const char *dot = strrchr(base, '.'); if (!dot) { const size_t n = strlen(spec); char *cand = (char *)malloc(n + 4); if (!cand) { return NULL; } memcpy(cand, spec, n); memcpy(cand + n, ".pl", 3); cand[n + 3] = '\0'; if (flowlog_fs_is_regular_file(cand)) { return cand; } free(cand); } return strdup(spec); } static bool flowlog_parse_consult_list_spec(const char *in, flowlog_strvec *out_paths, char **out_spec) { if (out_paths) { out_paths->items = NULL; out_paths->count = 0; out_paths->cap = 0; } if (out_spec) { *out_spec = NULL; } if (!in) { return false; } const char *start = in; while (*start && isspace((unsigned char)*start)) { start++; } const char *end = in + strlen(in); while (end > start && isspace((unsigned char)end[-1])) { end--; } if (end <= start) { return false; } // Allow an optional trailing '.' (REPL sentences always have one). if (end > start && end[-1] == '.') { end--; while (end > start && isspace((unsigned char)end[-1])) { end--; } } if (end <= start || *start != '[' || end[-1] != ']') { return false; } if (out_spec) { const size_t n = (size_t)(end - start); char *spec = (char *)malloc(n + 1); if (!spec) { return false; } memcpy(spec, start, n); spec[n] = '\0'; *out_spec = spec; } if (!out_paths) { return true; } const char *p = start + 1; const char *limit = end - 1; while (p < limit) { while (p < limit && isspace((unsigned char)*p)) { p++; } if (p >= limit) { break; } if (*p == ',') { p++; continue; } pl_sbuf item; sbuf_init(&item, NULL, NULL); if (*p == '\'' || *p == '"') { const char quote = *p++; bool closed = false; while (p < limit) { if (*p == quote) { if ((p + 1) < limit && p[1] == quote) { sbuf_append_char(&item, quote); p += 2; continue; } p++; closed = true; break; } if (*p == '\\' && (p + 1) < limit) { // Best-effort: allow common escapes in quoted paths. sbuf_append_char(&item, p[1]); p += 2; continue; } sbuf_append_char(&item, *p++); } if (!closed) { sbuf_free(&item); flowlog_strvec_free(out_paths); if (out_spec) { free(*out_spec); *out_spec = NULL; } return false; } } else { const char *q = p; while (q < limit && *q != ',') { q++; } // Trim whitespace in the token. const char *a = p; const char *b = q; while (a < b && isspace((unsigned char)*a)) { a++; } while (b > a && isspace((unsigned char)b[-1])) { b--; } if (b > a) { sbuf_append_mem(&item, a, (size_t)(b - a)); } p = q; } // Final trim. while (item.len && isspace((unsigned char)item.buf[item.len - 1])) { item.buf[--item.len] = '\0'; } if (item.buf && item.len) { char *s = strdup(item.buf); sbuf_free(&item); if (!s || !flowlog_strvec_push(out_paths, s)) { sbuf_free(&item); flowlog_strvec_free(out_paths); if (out_spec) { free(*out_spec); *out_spec = NULL; } return false; } } else { sbuf_free(&item); } } return true; } static pl_program *flowlog_program_load_repl_spec(const char *spec, const void *rt_ctrl, const ULO *dbg_dat_ptr) { if (!spec || !*spec) { return NULL; } flowlog_strvec paths = {0}; if (flowlog_parse_consult_list_spec(spec, &paths, NULL)) { if (!paths.count) { flowlog_strvec_free(&paths); return flowlog_program_from_src("", "", rt_ctrl, dbg_dat_ptr); } for (size_t i = 0; i < paths.count; i++) { char *rp = flowlog_resolve_program_path(paths.items[i]); if (!rp) { flowlog_strvec_free(&paths); return NULL; } free(paths.items[i]); paths.items[i] = rp; } pl_program *p = flowlog_program_load_files((const char *const *)paths.items, paths.count, rt_ctrl, dbg_dat_ptr); flowlog_strvec_free(&paths); return p; } char *rp = flowlog_resolve_program_path(spec); if (!rp) { return NULL; } pl_program *p = flowlog_program_load_file(rp, rt_ctrl, dbg_dat_ptr); free(rp); return p; } static bool repl_sentence_match_predicate(const char *s, const char *name, int arity) { if (!s || !name || arity < 0) { return false; } const char *p = s; while (*p && isspace((unsigned char)*p)) { p++; } const char *end = s + strlen(s); while (end > p && isspace((unsigned char)end[-1])) { end--; } if (end <= p) { return false; } if (end > p && end[-1] == '.') { end--; while (end > p && isspace((unsigned char)end[-1])) { end--; } } if (end <= p) { return false; } const size_t name_len = strlen(name); if ((size_t)(end - p) < name_len) { return false; } if (strncmp(p, name, name_len) != 0) { return false; } p += name_len; while (p < end && isspace((unsigned char)*p)) { p++; } if (arity == 0) { return p == end; } if (arity == 1) { if (p >= end || *p != '(') { return false; } p++; while (p < end && isspace((unsigned char)*p)) { p++; } if (p >= end) { return false; } if (end[-1] != ')') { return false; } const char *q = end - 1; while (q > p && isspace((unsigned char)q[-1])) { q--; } return q > p; } return false; } static bool repl_sentence_is_atom_command(const char *s, const char *name) { return repl_sentence_match_predicate(s, name, 0); } static bool repl_sentence_is_quit_command(const char *s) { return repl_sentence_match_predicate(s, "halt", 0) || repl_sentence_match_predicate(s, "quit", 0); } static bool repl_sentence_is_help_command(const char *s) { return repl_sentence_match_predicate(s, "help", 0) || repl_sentence_is_atom_command(s, ":help"); } static bool repl_sentence_is_reload_command(const char *s) { return repl_sentence_is_atom_command(s, ":reload"); } static void repl_print_help(void) { (void)fprintf(stdout, "Commands:\n" " help. show this help\n" " halt. / quit. exit\n" " :load load program file\n" " :reload reload last loaded program\n" " [file]. load program file (consult)\n" " expand. print saved solutions from last query\n" " solutions(X). replay saved solutions one-by-one\n" "Notes:\n" " - Queries should end with '.'\n" " - After solutions: SPACE/';'/n => 5 more, 'a' => all, 'w'/'x' => full terms, Enter/'.' => stop\n" " - Ctrl-X prints saved full solutions and keeps current input line\n" " - Ctrl-D exits the REPL at a fresh prompt\n" " - Use set_prolog_flag(flowlog_parallel_profile, iso|off) for classic behavior.\n"); } static void repl_replay_cached_solutions_one_by_one(const repl_solution_cache *cache, bool tty) { if (!cache || cache->count == 0) { repl_print_final_false(false); return; } if (!tty) { repl_print_cached_solutions_all(cache); return; } size_t idx = 0; repl_print_solution_line(cache->items[idx], true); idx++; while (idx < cache->count) { const repl_solution_action act = repl_read_solution_action_timeout(-1, NULL); if (act == REPL_SOLUTION_MORE) { repl_print_solution_line(cache->items[idx], false); idx++; continue; } if (act == REPL_SOLUTION_ALL) { while (idx < cache->count) { repl_print_solution_line(cache->items[idx], false); idx++; } if (cache->partial) { repl_print_final_ellipsis(); } else { repl_print_final_dot(); } return; } if (act == REPL_SOLUTION_WRITE_FULL) { flowlog_write_stdout_mem("\n", 1); repl_print_cached_solutions_all(cache); continue; } if (act == REPL_SOLUTION_NONE) { continue; } repl_print_final_ellipsis(); return; } if (cache->partial) { repl_print_final_ellipsis(); } else { repl_print_final_dot(); } } static void flowlog_repl(pl_program **prog_io, char **prog_path_io, const void *rt_ctrl, const ULO *dbg_dat_ptr) { pl_program *prog = prog_io ? *prog_io : NULL; char *prog_path = prog_path_io ? *prog_path_io : NULL; g_current_prog = prog; g_loaded_program_path = prog_path; const bool tty = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO); pl_repl_history hist = {0}; repl_history_init(&hist, tty); if (tty) { (void)fprintf(stdout, "%s\n", FLOWLOG_VERSION); } pl_sbuf in; sbuf_init(&in, rt_ctrl, dbg_dat_ptr); repl_solution_cache last_solutions = {0}; for (;;) { if (!flowlog_repl_read_sentence(&in, &hist, &last_solutions)) { break; } // Trim leading whitespace for command checks. const char *s = in.buf ? in.buf : ""; while (*s && isspace((unsigned char)*s)) { s++; } if (repl_sentence_is_quit_command(s)) { break; } if (repl_sentence_is_help_command(s)) { repl_print_help(); continue; } if (repl_sentence_match_predicate(s, "expand", 0)) { repl_print_cached_solutions_all(&last_solutions); continue; } if (repl_sentence_match_predicate(s, "solutions", 1)) { repl_replay_cached_solutions_one_by_one(&last_solutions, tty); continue; } if (!strncmp(s, ":load", 5) && isspace((unsigned char)s[5])) { const char *p = s + 5; while (*p && isspace((unsigned char)*p)) { p++; } char *path = strdup(p); if (!path) { (void)fprintf(stderr, "flowlog: out of memory\n"); continue; } // strip trailing whitespace/newline size_t n = strlen(path); while (n > 0 && isspace((unsigned char)path[n - 1])) { path[--n] = '\0'; } if (!*path) { free(path); (void)fprintf(stderr, "flowlog: :load requires a file path\n"); continue; } pl_program *np = flowlog_program_load_file(path, rt_ctrl, dbg_dat_ptr); if (!np) { (void)fprintf(stderr, "flowlog: cannot load: %s\n", path); free(path); continue; } if (prog) { flowlog_program_free(prog, rt_ctrl, dbg_dat_ptr); } free(prog_path); prog_path = path; prog = np; g_current_prog = prog; g_loaded_program_path = prog_path; (void)fprintf(stdout, "Program: %s\n", prog_path); int init_exit = 0; if (flowlog_run_init_goals(prog, rt_ctrl, dbg_dat_ptr, &init_exit)) { break; } continue; } if (repl_sentence_is_reload_command(s)) { if (!prog_path || !*prog_path) { (void)fprintf(stderr, "flowlog: no program loaded\n"); continue; } pl_program *np = flowlog_program_load_repl_spec(prog_path, rt_ctrl, dbg_dat_ptr); if (!np) { (void)fprintf(stderr, "flowlog: cannot reload: %s\n", prog_path); continue; } if (prog) { flowlog_program_free(prog, rt_ctrl, dbg_dat_ptr); } prog = np; g_current_prog = prog; g_loaded_program_path = prog_path; (void)fprintf(stdout, "Program: %s\n", prog_path); int init_exit = 0; if (flowlog_run_init_goals(prog, rt_ctrl, dbg_dat_ptr, &init_exit)) { break; } continue; } // Prolog top-level convenience: treat a lone list goal like `[file].` as // a "consult" command that loads one or more source files. flowlog_strvec consult_paths = {0}; char *consult_spec = NULL; if (flowlog_parse_consult_list_spec(s, &consult_paths, &consult_spec)) { if (!consult_paths.count) { flowlog_strvec_free(&consult_paths); free(consult_spec); continue; } bool ok = true; for (size_t i = 0; i < consult_paths.count; i++) { char *rp = flowlog_resolve_program_path(consult_paths.items[i]); if (!rp) { (void)fprintf(stderr, "flowlog: out of memory\n"); ok = false; break; } free(consult_paths.items[i]); consult_paths.items[i] = rp; } if (!ok) { flowlog_strvec_free(&consult_paths); free(consult_spec); continue; } if (consult_paths.count) { pl_program *np = flowlog_program_load_files((const char *const *)consult_paths.items, consult_paths.count, rt_ctrl, dbg_dat_ptr); if (!np) { (void)fprintf(stderr, "flowlog: cannot load: %s\n", consult_spec ? consult_spec : "(consult)"); flowlog_strvec_free(&consult_paths); free(consult_spec); continue; } if (prog) { flowlog_program_free(prog, rt_ctrl, dbg_dat_ptr); } free(prog_path); if (consult_paths.count == 1) { prog_path = consult_paths.items[0]; consult_paths.items[0] = NULL; free(consult_spec); } else { prog_path = consult_spec; } consult_spec = NULL; prog = np; g_current_prog = prog; g_loaded_program_path = prog_path; (void)fprintf(stdout, "Program: %s\n", prog_path ? prog_path : "[user]"); int init_exit = 0; if (flowlog_run_init_goals(prog, rt_ctrl, dbg_dat_ptr, &init_exit)) { flowlog_strvec_free(&consult_paths); break; } flowlog_strvec_free(&consult_paths); continue; } flowlog_strvec_free(&consult_paths); free(consult_spec); } int halt_code = 0; const bool halted = flowlog_run_query_repl(prog, s, tty, rt_ctrl, dbg_dat_ptr, &last_solutions, &halt_code); if (halted) { break; } } repl_solution_cache_clear(&last_solutions); sbuf_free(&in); repl_history_free(&hist); g_current_prog = NULL; g_loaded_program_path = NULL; if (prog_io) { *prog_io = prog; } if (prog_path_io) { *prog_path_io = prog_path; } else { free(prog_path); } } /* --- SUBSECTION 26.3: CLI Main Entry ------------------------------------- */ // CLI main entry and query runner. // flowlog_main_impl() drives CLI/REPL; flowlog_should_stack_boost() and flowlog_main_stack_boost_size_bytes() manage stack boosting; main() is entrypoint. static int flowlog_main_impl(int argc, char **argv) { static const ULO dbg_dat[1] = {0}; const void *rt_ctrl = (const void *)(uintptr_t)1; flowlog_install_signal_handlers(); flowlog_cstack_init_once(); const char *env_cpus = getenv("FLOWLOG_N_CPUPROC"); if (env_cpus && *env_cpus) { char *end = NULL; unsigned long long v = strtoull(env_cpus, &end, 10); if (end && *end == '\0' && v > 0) { g_ncpuproc_override = (ULO)v; } } bool env_trace_on = false; { const char *e = getenv("FLOWLOG_TRACE"); env_trace_on = (e && *e && strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false")); } bool env_itrace_on = false; { const char *e = getenv("FLOWLOG_ITRACE"); env_itrace_on = (e && *e && strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false")); } bool env_itrace_watermark_on = false; { const char *e = getenv("FLOWLOG_ITRACE_WATERMARK"); env_itrace_watermark_on = (e && *e && strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false")); } #if defined(SIGSEGV) bool env_segv_trace_on = false; { const char *e = getenv("FLOWLOG_SEGV_TRACE"); env_segv_trace_on = (e && *e && strcmp(e, "0") && strcmp(e, "off") && strcmp(e, "false")); } #endif { const char *e = getenv("FLOWLOG_CSTACK_LIMIT"); if (e && *e) { size_t v = 0; if (!flowlog_parse_size_bytes(e, &v)) { (void)fprintf(stderr, "flowlog: invalid FLOWLOG_CSTACK_LIMIT: %s\n", e); return 2; } g_cstack_limit_bytes = v; } } flowlog_strvec system_files = {0}; flowlog_file_arg_segments positional_segments = {0}; bool positional_mode = false; bool fast_startup = false; const char *query = NULL; bool have_engine_override = false; pl_engine_mode engine_override = PL_ENGINE_INTERP; bool have_par_profile_override = false; const char *par_profile_override = NULL; bool have_trace_override = false; bool trace_override = false; bool have_itrace_override = false; bool itrace_override = false; bool have_itrace_watermark_override = false; bool itrace_watermark_override = false; #if defined(SIGSEGV) bool have_segv_trace_override = false; bool segv_trace_override = false; #endif for (int i = 1; i < argc; i++) { const char *a = argv[i]; if (positional_mode) { if (a && *a && flowlog_fs_is_regular_file(a)) { if (!flowlog_file_arg_segments_push_file_dup(&positional_segments, a)) { return flowlog_cli_fail_oom(&system_files, &positional_segments); } continue; } if (!flowlog_file_arg_segments_push_arg_dup(&positional_segments, a)) { return flowlog_cli_fail_oom(&system_files, &positional_segments); } continue; } if (!strcmp(a, "-h") || !strcmp(a, "--help")) { flowlog_usage(stdout); flowlog_cli_parse_state_free(&system_files, &positional_segments); return 0; } if (!strcmp(a, "-v") || !strcmp(a, "--version")) { (void)printf("%s\n", FLOWLOG_VERSION); flowlog_cli_parse_state_free(&system_files, &positional_segments); return 0; } if (!strcmp(a, "--trace")) { have_trace_override = true; trace_override = true; continue; } if (!strcmp(a, "--notrace")) { have_trace_override = true; trace_override = false; continue; } if (!strcmp(a, "--itrace")) { have_itrace_override = true; itrace_override = true; continue; } if (!strcmp(a, "--noitrace")) { have_itrace_override = true; itrace_override = false; continue; } if (!strcmp(a, "--itrace-watermark")) { have_itrace_watermark_override = true; itrace_watermark_override = true; continue; } if (!strcmp(a, "--noitrace-watermark")) { have_itrace_watermark_override = true; itrace_watermark_override = false; continue; } #if defined(SIGSEGV) if (!strcmp(a, "--segv-trace")) { have_segv_trace_override = true; segv_trace_override = true; continue; } if (!strcmp(a, "--nosegv-trace")) { have_segv_trace_override = true; segv_trace_override = false; continue; } #endif if (!strcmp(a, "-f") || !strcmp(a, "--fast")) { fast_startup = true; continue; } if (!strcmp(a, "-l") || !strcmp(a, "--load")) { if (i + 1 >= argc || !argv[i + 1] || !*argv[i + 1] || argv[i + 1][0] == '-') { return flowlog_cli_fail_requires_file(&system_files, &positional_segments, a); } if (!flowlog_strvec_push_dup(&system_files, argv[++i])) { return flowlog_cli_fail_oom(&system_files, &positional_segments); } continue; } if (!strcmp(a, "-g") || !strcmp(a, "--goal") || !strcmp(a, "--query")) { if (i + 1 >= argc) { return flowlog_cli_fail_requires_arg(&system_files, &positional_segments, a); } query = argv[++i]; continue; } if (!strcmp(a, "--threads") || !strcmp(a, "--cpus") || !strcmp(a, "--cpuprocs")) { if (i + 1 >= argc) { return flowlog_cli_fail_requires_arg(&system_files, &positional_segments, a); } const char *v = argv[++i]; char *end = NULL; unsigned long long n = strtoull(v, &end, 10); if (!end || *end != '\0' || n == 0) { (void)fprintf(stderr, "flowlog: invalid thread count: %s\n", v); flowlog_cli_parse_state_free(&system_files, &positional_segments); return 2; } g_ncpuproc_override = (ULO)n; continue; } if (!strcmp(a, "--engine")) { if (i + 1 >= argc) { return flowlog_cli_fail_requires_arg(&system_files, &positional_segments, a); } const char *v = argv[++i]; if (!strcmp(v, "interp")) { have_engine_override = true; engine_override = PL_ENGINE_INTERP; } else if (!strcmp(v, "tree")) { have_engine_override = true; engine_override = PL_ENGINE_INTERP; } else if (!strcmp(v, "wam")) { have_engine_override = true; engine_override = PL_ENGINE_WAM; } else if (!strcmp(v, "wamvm")) { have_engine_override = true; engine_override = PL_ENGINE_WAMVM; } else { (void)fprintf(stderr, "flowlog: invalid --engine: %s\n", v); flowlog_cli_parse_state_free(&system_files, &positional_segments); return 2; } continue; } if (!strcmp(a, "--parallel-profile") || !strcmp(a, "--parallel_profile")) { if (i + 1 >= argc) { return flowlog_cli_fail_requires_arg(&system_files, &positional_segments, a); } const char *v = argv[++i]; if (!strcmp(v, "off") || !strcmp(v, "iso") || !strcmp(v, "fast")) { have_par_profile_override = true; par_profile_override = v; } else { (void)fprintf(stderr, "flowlog: invalid --parallel-profile: %s\n", v); flowlog_cli_parse_state_free(&system_files, &positional_segments); return 2; } continue; } if (!strcmp(a, "--cstack-limit")) { if (i + 1 >= argc) { return flowlog_cli_fail_requires_arg(&system_files, &positional_segments, a); } const char *v = argv[++i]; size_t bytes = 0; if (!flowlog_parse_size_bytes(v, &bytes)) { (void)fprintf(stderr, "flowlog: invalid --cstack-limit: %s\n", v); flowlog_cli_parse_state_free(&system_files, &positional_segments); return 2; } g_cstack_limit_bytes = bytes; continue; } if (a && a[0] && a[0] != '-') { if (!flowlog_file_arg_segments_push_file_dup(&positional_segments, a)) { return flowlog_cli_fail_oom(&system_files, &positional_segments); } positional_mode = true; continue; } (void)fprintf(stderr, "flowlog: unknown arg: %s\n", a); flowlog_usage(stderr); flowlog_cli_parse_state_free(&system_files, &positional_segments); return 2; } #if defined(SIGSEGV) const bool segv_trace_enabled = have_segv_trace_override ? segv_trace_override : env_segv_trace_on; flowlog_install_sigsegv_trace_handler(segv_trace_enabled); #endif streams_init(dbg_dat); flowlog_strvec startup_paths = {0}; if (!fast_startup) { CHR *rc_path = flowlog_rc_default_path(); if (rc_path && *rc_path && flowlog_fs_is_regular_file(rc_path)) { if (!flowlog_strvec_push(&startup_paths, rc_path)) { flowlog_strvec_free(&startup_paths); return flowlog_cli_fail_oom(&system_files, &positional_segments); } rc_path = NULL; } free(rc_path); } for (size_t i = 0; i < system_files.count; i++) { if (!flowlog_strvec_push_dup(&startup_paths, system_files.items[i])) { flowlog_strvec_free(&startup_paths); return flowlog_cli_fail_oom(&system_files, &positional_segments); } } for (size_t i = 0; i < positional_segments.count; i++) { if (!flowlog_strvec_push_dup(&startup_paths, positional_segments.items[i].path)) { flowlog_strvec_free(&startup_paths); return flowlog_cli_fail_oom(&system_files, &positional_segments); } } flowlog_strvec_free(&system_files); pl_program *prog = NULL; char *prog_path = NULL; const size_t startup_count = startup_paths.count; prog = flowlog_program_load_files((const char *const *)startup_paths.items, startup_paths.count, rt_ctrl, dbg_dat); if (!prog) { if (startup_paths.count == 1 && startup_paths.items[0] && *startup_paths.items[0]) { (void)fprintf(stderr, "flowlog: cannot load program: %s\n", startup_paths.items[0]); } else { (void)fprintf(stderr, "flowlog: cannot load startup files\n"); } flowlog_strvec_free(&startup_paths); flowlog_cli_parse_state_free(NULL, &positional_segments); return 1; } if (startup_count == 1) { prog_path = startup_paths.items[0] ? strdup(startup_paths.items[0]) : NULL; } else if (startup_count > 1) { prog_path = flowlog_format_consult_spec((const char *const *)startup_paths.items, startup_count); } flowlog_strvec_free(&startup_paths); if (startup_count && !prog_path) { flowlog_program_free(prog, rt_ctrl, dbg_dat); return flowlog_cli_fail_oom(NULL, &positional_segments); } const CHR *const *default_argv = NULL; ULO default_argc = 0; if (positional_segments.count) { const flowlog_file_arg_segment *seg0 = &positional_segments.items[0]; default_argv = (const CHR *const *)seg0->argv.items; default_argc = (ULO)seg0->argv.count; } if (!flowlog_program_set_default_argv(prog, default_argv, default_argc, rt_ctrl, dbg_dat)) { flowlog_program_free(prog, rt_ctrl, dbg_dat); free(prog_path); return flowlog_cli_fail_oom(NULL, &positional_segments); } for (size_t i = 0; i < positional_segments.count; i++) { const flowlog_file_arg_segment *seg = &positional_segments.items[i]; if (!flowlog_program_add_src_argv(prog, seg->path, (const CHR *const *)seg->argv.items, (ULO)seg->argv.count, rt_ctrl, dbg_dat)) { flowlog_program_free(prog, rt_ctrl, dbg_dat); free(prog_path); return flowlog_cli_fail_oom(NULL, &positional_segments); } } flowlog_program_use_default_argv(prog); flowlog_cli_parse_state_free(NULL, &positional_segments); g_loaded_program_path = prog_path; // Apply CLI overrides after loading the program so they can override load-time directives. if (prog) { if (have_engine_override) { prog->flag_engine = engine_override; } if (have_par_profile_override && par_profile_override) { if (!strcmp(par_profile_override, "off")) { prog->flag_parallel_or = false; prog->flag_parallel_and = false; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else if (!strcmp(par_profile_override, "iso")) { prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_ORDERED; prog->flag_parallel_or_nesting = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING; } else { // fast prog->flag_parallel_or = true; prog->flag_parallel_and = true; prog->flag_parallel_or_order = PL_OR_UNORDERED; // Enable deeper nesting automatically on very high-core systems so deep // nondet search can keep many CPUs busy when top-level branching is small. SLO nest = (SLO)FLOWLOG_DEFAULT_PARALLEL_OR_NESTING_FAST; const ULO ncpu = get_n_cpuproc(); if (ncpu >= 128) { nest = 8; } else if (ncpu >= 64) { nest = 4; } else if (ncpu >= 32) { nest = 2; } prog->flag_parallel_or_nesting = nest; } } if (have_trace_override) { if (trace_override) { prog->flag_trace = true; prog->flag_debug = true; } else { prog->flag_trace = false; } } else if (env_trace_on) { prog->flag_trace = true; prog->flag_debug = true; } if (have_itrace_override) { if (itrace_override) { prog->flag_itrace = true; prog->flag_debug = true; } else { prog->flag_itrace = false; } } else if (env_itrace_on) { prog->flag_itrace = true; prog->flag_debug = true; } if (have_itrace_watermark_override) { prog->flag_itrace_watermark = itrace_watermark_override; if (itrace_watermark_override) { prog->flag_itrace = true; prog->flag_debug = true; } } else if (env_itrace_watermark_on) { prog->flag_itrace_watermark = true; prog->flag_itrace = true; prog->flag_debug = true; } } int init_exit_code = 0; if (flowlog_run_init_goals(prog, rt_ctrl, dbg_dat, &init_exit_code)) { flowlog_program_free(prog, rt_ctrl, dbg_dat); free(prog_path); return init_exit_code; } if (query) { int halt_code = 0; const bool halted = flowlog_run_query(prog, query, rt_ctrl, dbg_dat, &halt_code); flowlog_program_free(prog, rt_ctrl, dbg_dat); free(prog_path); if (halted) { return halt_code; } return 0; } flowlog_repl(&prog, &prog_path, rt_ctrl, dbg_dat); flowlog_program_free(prog, rt_ctrl, dbg_dat); free(prog_path); return 0; } typedef struct { int argc; char **argv; int exit_code; } flowlog_main_stack_ctx; static void *flowlog_main_stack_thread(void *arg) { flowlog_main_stack_ctx *ctx = (flowlog_main_stack_ctx *)arg; if (!ctx) { return NULL; } ctx->exit_code = flowlog_main_impl(ctx->argc, ctx->argv); return NULL; } static bool flowlog_should_stack_boost(size_t *out_limit_bytes) { if (out_limit_bytes) { *out_limit_bytes = 0; } const char *e = getenv("FLOWLOG_STACK_BOOST"); if (e && *e) { if (!strcmp(e, "0") || !strcmp(e, "off") || !strcmp(e, "false")) { return false; } if (!strcmp(e, "1") || !strcmp(e, "on") || !strcmp(e, "true") || !strcmp(e, "force")) { return true; } } struct rlimit rl; if (getrlimit(RLIMIT_STACK, &rl) != 0) { return false; } if (rl.rlim_cur == RLIM_INFINITY) { return false; } if (rl.rlim_cur <= 0) { return false; } const unsigned long long cur_ull = (unsigned long long)rl.rlim_cur; const size_t cur = (cur_ull > (unsigned long long)SIZE_MAX) ? SIZE_MAX : (size_t)cur_ull; if (out_limit_bytes) { *out_limit_bytes = cur; } // Linux often defaults to 8MB stacks. The tree-walking interpreter can // exhaust this on deep recursion (e.g. quad tests), so run on a dedicated // pthread with a larger stack in that case. const size_t threshold = (size_t)16u * 1024u * 1024u; return cur < threshold; } static size_t flowlog_main_stack_boost_size_bytes(size_t stack_limit_bytes) { size_t stack_sz = (size_t)64u * 1024u * 1024u; if (stack_limit_bytes > 0 && stack_limit_bytes < stack_sz) { // Scale up relative to the configured main stack limit, but keep a sane // default floor for Linux. size_t scaled = stack_limit_bytes * 8u; if (scaled > stack_sz) { stack_sz = scaled; } } const char *env = getenv("FLOWLOG_MAIN_STACK_SIZE"); if (env && *env) { size_t v = 0; if (flowlog_parse_size_bytes(env, &v) && v >= (size_t)PTHREAD_STACK_MIN) { stack_sz = v; } } if (stack_sz < (size_t)PTHREAD_STACK_MIN) { stack_sz = (size_t)PTHREAD_STACK_MIN; } long page_sz = -1; #if defined(_SC_PAGESIZE) page_sz = sysconf(_SC_PAGESIZE); #elif defined(_SC_PAGE_SIZE) page_sz = sysconf(_SC_PAGE_SIZE); #endif if (page_sz > 0) { const size_t p = (size_t)page_sz; stack_sz = ((stack_sz + p - 1) / p) * p; } return stack_sz; } int main(int argc, char **argv) { size_t stack_limit_bytes = 0; if (!flowlog_should_stack_boost(&stack_limit_bytes)) { return flowlog_main_impl(argc, argv); } // When running Flowlog's main loop on a boosted-stack worker thread, ensure // SIGINT/SIGINFO are delivered to that worker (not this launcher thread). // Otherwise, the signal handler may run on the launcher thread while the // solver checks the pending flag on the worker thread, which is a data race // on `sig_atomic_t` and can drop SIGINFO status reports. sigset_t set; (void)sigemptyset(&set); (void)sigaddset(&set, SIGINT); #if defined(SIGINFO) (void)sigaddset(&set, SIGINFO); #endif (void)pthread_sigmask(SIG_BLOCK, &set, NULL); const size_t stack_sz = flowlog_main_stack_boost_size_bytes(stack_limit_bytes); flowlog_main_stack_ctx ctx = {.argc = argc, .argv = argv, .exit_code = 0}; pthread_attr_t attr; bool have_attr = (pthread_attr_init(&attr) == 0); if (have_attr) { (void)pthread_attr_setstacksize(&attr, stack_sz); } pthread_t th; const int rc = pthread_create(&th, have_attr ? &attr : NULL, flowlog_main_stack_thread, &ctx); if (have_attr) { (void)pthread_attr_destroy(&attr); } if (rc != 0) { return flowlog_main_impl(argc, argv); } (void)pthread_join(th, NULL); return ctx.exit_code; }