diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index eed9d036..a378e1a0 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -68,6 +68,11 @@ make docs # Generates Mermaid diagrams from YAML schemas ## C Coding Conventions +### Comments + +- Only comment when necessary to explain non-obvious code or rationale. +- Keep comments terse and on point. + ### Generated union constructor functions - `new_(parserInfo, variant)` - Wraps an existing variant in a union @@ -88,6 +93,13 @@ make docs # Generates Mermaid diagrams from YAML schemas - Always use explicit NULL comparisons: `if (ptr != NULL)` or `if (ptr == NULL)` +### Boolean values + +- Use `bool` for variables and return values that represent truth values. +- Do not use `int` as a boolean substitute when the API returns boolean semantics. +- Prefer direct boolean checks (e.g., `if (flag)`) and assertions (e.g., `assert(flag)`). +- Example: `bool matches = eqTerm(actual, expected); assert(matches);` + ### Naming Conventions - Types: `MixedCase` (e.g., `LamExp`, `AstExpression`) @@ -96,12 +108,13 @@ make docs # Generates Mermaid diagrams from YAML schemas ## Documentation Style -- Use simple periods instead of exclamation points -- Avoid hyperbole: use "significant", "notable" instead of "HUGE", "Amazing" -- Avoid emphatic modifiers in headings and verdict-style declarations -- No emoji -- Minimize bold emphasis on routine statements -- Follow markdownlint rules +- Use simple periods instead of exclamation points. +- Avoid hyperbole: use "significant", "notable" instead of "HUGE", "Amazing". +- Avoid emphatic modifiers in headings and verdict-style declarations. +- No emoji. +- Minimize bold emphasis on routine statements. +- Follow markdownlint rules. +- Prefer Mermaid for diagrams. ## Debugging @@ -170,6 +183,12 @@ For detailed information on specific compiler stages, see: - [anf.md](../docs/agent/anf.md) - A-Normal Form conversion - [language-syntax.md](../docs/agent/language-syntax.md) - F♮ language reference +## Rewrite Prototyping + +For guidance on the self-hosting/prototyping pipeline in `fn/rewrite`, including `test_harness.fn`, pass ordering, and `samples.fn` usage, see: + +- [rewrite-self-hosting-guide.md](../docs/agents/rewrite-self-hosting-guide.md) + ## When Reading Code - Start at `src/main.c` for overall flow diff --git a/.github/workflows/makefile.yml b/.github/workflows/makefile.yml index 28f62e8e..131a1cf7 100644 --- a/.github/workflows/makefile.yml +++ b/.github/workflows/makefile.yml @@ -10,6 +10,10 @@ jobs: build: runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + compiler: [gcc, clang] steps: - uses: actions/checkout@v3 @@ -17,8 +21,12 @@ jobs: - name: Install sqlite run: make install-sqlite3 - - name: Build executable - run: make CCC=gcc MODE=testing + - name: Install clang + if: matrix.compiler == 'clang' + run: sudo apt-get update && sudo apt-get --yes install clang - - name: Run tests - run: make test CCC=gcc MODE=testing + - name: Build executable (${{ matrix.compiler }}) + run: make CCC=${{ matrix.compiler }} MODE=testing + + - name: Run tests (${{ matrix.compiler }}) + run: make test CCC=${{ matrix.compiler }} MODE=testing diff --git a/docs/CPS_COMPLETE_GUIDE.md b/docs/CPS_COMPLETE_GUIDE.md index ffdb6fd9..c6615762 100644 --- a/docs/CPS_COMPLETE_GUIDE.md +++ b/docs/CPS_COMPLETE_GUIDE.md @@ -185,6 +185,67 @@ When examining CPS output, verify: --- +## Optimization Staging Around CPS + +The project already has working CPS transforms in [src/lambda_cpsTc.c](src/lambda_cpsTc.c) and [src/lambda_cpsTk.c](src/lambda_cpsTk.c). + +A practical optimization schedule is: + +1. Light simplification before CPS. +2. CPS transform. +3. Aggressive administrative reduction after CPS. + +### Why split optimization this way + +- Pre-CPS simplification reduces CPS output size and compile-time churn. +- Post-CPS simplification removes the large volume of administrative redexes introduced by CPS. +- In a strict language with effects and letrec, aggressive source-level beta/eta is riskier than CPS-level cleanup. + +### Pre-CPS: keep it conservative + +Before CPS, keep reductions safe and local: + +- Beta only when argument shape is known-safe under call-by-value policy. +- Eta only when no effect or recursion-order hazard is introduced. +- Letrec-aware eta should not contract wrappers that reference letrec-bound symbols. + +This keeps source semantics stable before control flow is made explicit. + +### Post-CPS: do the heavy cleanup + +After CPS, prioritize administrative reductions: + +- Beta: contract immediate continuation wrappers and one-shot binders. +- Eta: remove continuation forwarding wrappers when they are pure forwarding. +- Dead continuation bindings: drop continuation lambdas that are never used. + +Typical wins come from patterns like: + +```fn +((λ (k) body) c) +``` + +and + +```fn +(λ (x k) (f x k)) +``` + +when no letrec-sensitive recursion or effect ordering is changed. + +### Suggested safety checks for CPS-era eta + +For a candidate contraction: + +- Ensure forwarded arguments are exactly the lambda parameters. +- Ensure no duplicated evaluation is introduced. +- Ensure recursive group symbols are not crossed in a way that changes forcing/arity behavior. +- Ensure effectful primitives are not reordered. + +This gives a robust default: small, safe pre-CPS simplification and high-leverage post-CPS normalization. + +--- + ## Examples with Expected Output ### Example 1: Simple Application diff --git a/docs/README.md b/docs/README.md index d9359625..263ead01 100644 --- a/docs/README.md +++ b/docs/README.md @@ -3,6 +3,7 @@ * [ANF](ANF.md) A-Normalization * [Arithmetic](Arithmetic.md) Notes on rational and complex arithmetic. * [CODEGEN](CODEGEN.md) Notes on the code generator utility. +* [CPS COMPLETE GUIDE](CPS_COMPLETE_GUIDE.md) CPS transformation notes and optimization staging. * [ENV](ENV.md) Abandoned plan to have first-class environments. * [LEXICAL ADDRESSING](LEXICAL_ADDRESSING.md) De-Bruijn indexing for fast variable look up. * [MACROS](MACROS.md) Initial thoughts on a simple macro system. diff --git a/docs/TODO.md b/docs/TODO.md index 91b46a31..f9ed4cb9 100644 --- a/docs/TODO.md +++ b/docs/TODO.md @@ -3,8 +3,6 @@ More of a wish-list than a hard and fast plan. * Simplify - * Add a beta-reduction pass (after cps-transform). - * Add an eta-reduction pass. * Add a constant/operator folding pass after beta and eta reduction. * Target LLVM * `syntax` construct that allows large-scale syntactic structures to be defined by the user. diff --git a/docs/agent/code-generation.md b/docs/agent/code-generation.md index 9b754ee2..641c61b9 100644 --- a/docs/agent/code-generation.md +++ b/docs/agent/code-generation.md @@ -4,7 +4,7 @@ The build depends heavily on Python code generation. **Do not manually edit file ## Overview -The code generator is modular: the main entry point is `tools/generate.py`, which orchestrates the `generate` Python package (in `tools/generate/`). This package contains all logic for parsing YAML schemas and generating C code for all compiler stages. Contains modules for each type of generated structure (structs, discriminated unions, hashes, arrays etc.) +The code generator is modular: the main entry point is `tools/generate.py`, which orchestrates the `generate` Python package (in `tools/generate/`). This package contains all logic for parsing YAML schemas and generating C code for all compiler stages. It contains modules for each type of generated structure (structs, discriminated unions, hashes, arrays etc.) ## YAML Schema Structure @@ -70,6 +70,16 @@ hashes: The yaml may also contain an `inline` section which in turn can contain arrays, unions and structs. These inline variants are not separately memory managed (no GC header), are often passed by value, and may be used as components of structs without the extra pointer indirection. +The yaml may also contain an `external` section: + +```yaml +external: +- !include tc.yaml +- !include utils.yaml +``` + +External includes are loaded into the same `Catalog`, so cross-stage type information is available during generation. These entries are flagged as external and are not emitted as local generated definitions. + ## Primitives (`src/primitives.yaml`) Common types shared across all stages - referenced via `!include primitives.yaml`: @@ -139,6 +149,23 @@ For each struct/union, the code generator produces: 4. **Include headers** in your C code: `#include ".h"` 5. **Use generated functions** - no manual memory management code needed +## Manual Visitor Boilerplate + +Visitor generation is primarily a manual scaffolding workflow for creating an initial C file that is then edited by hand. + +Use: + +```bash +python3 tools/generate.py src/.yaml visitor --target= > generated/__visitor.c +``` + +Notes: + +- `target` prefixes generated function names (example: `cpsTkLamExp`). +- The generated file includes `#include "_.h"`; ensure that header exists before compiling. +- Visitor output includes only non-external entities from the current stage YAML. +- Regenerate only when re-scaffolding. Once manual edits begin, treat the visitor file as hand-maintained C code. + ## Important Notes - **ParserInfo**: If `parserInfo: true`, all structs get `ParserInfo I` field for error reporting source file and line number. @@ -146,6 +173,7 @@ For each struct/union, the code generator produces: - **GC Integration**: All generated `new*()` functions automatically register with GC - **Type safety**: Generated code includes type checking in mark/free dispatchers - **Documentation**: YAML `meta` blocks generate doxygen-style comments +- **External entries**: Types from `external:` are available for references and type resolution, but code generation only emits non-external entities for the current stage. ## Adding New Structures diff --git a/docs/agent/workflows.md b/docs/agent/workflows.md index 2e2ea51a..5f048440 100644 --- a/docs/agent/workflows.md +++ b/docs/agent/workflows.md @@ -26,6 +26,23 @@ The compiler uses two distinct mechanisms for reporting errors depending on thei Check `utils_helper.[ch]` before implementing functions over common types defined in `utils.yaml`, if you do need to implement something, consider adding it to `utils_helper.[ch]` if it could be useful elsewhere. +## Root Shell Helpers (`utils.sh`) + +There is a project-level shell helper file at `./utils.sh`. Agents working from the command line should be aware of it, and may source it when useful: + +```bash +source ./utils.sh +``` + +Notable quality-of-life helpers include: + +* `new_h `: creates `src/.h` with include guards and GPL header text. +* `new_c `: creates `src/.c` with GPL header text. +* `new_ch `: creates matching `.c/.h` pair and adds `#include ".h"` to the `.c` file. +* `new_visitor `: creates `src/_.h` and generates visitor boilerplate C from `src/.yaml`. + +If an agent does not use these helpers directly, it should still follow the same creation patterns (especially GPL header insertion and header guard style) when creating new source files manually. + ## Adding a Built-in Function To add a new native function callable from F♮ code: diff --git a/docs/agents/rewrite-self-hosting-guide.md b/docs/agents/rewrite-self-hosting-guide.md new file mode 100644 index 00000000..861c7b47 --- /dev/null +++ b/docs/agents/rewrite-self-hosting-guide.md @@ -0,0 +1,115 @@ +# Rewrite self-hosting guide for agents + +This document explains the `fn/rewrite` area so agents can reason about it as a prototype pipeline for compiler stages. + +## Why this folder matters + +`fn/rewrite` is not just experimental code. It is a staging area where algorithms are prototyped in the language itself before or alongside C implementations. + +Recent and relevant examples: + +- β-reduction is implemented in `fn/rewrite/beta_reduce.fn`. +- η-reduction is implemented in `fn/rewrite/eta_reduce.fn`. +- Constant/operator folding is implemented in `fn/rewrite/constant_folding.fn`. +- Closure conversion variants are in `fn/rewrite/closure-convert.fn`. + +Treat this directory as a design/prototyping reference when working on equivalent C stages. + +## Primary entrypoint + +Start with `fn/rewrite/test_harness.fn`. + +It loads: + +- `samples.fn` input corpus. +- Front-end representation and parser from `expr.fn`. +- Lower-level representation from `minexpr.fn`. +- Transform passes: `desugar`, `curry`, `eta_reduce`, `cps`, `beta_reduce`, `constant_folding`, `closure-convert`. + +### Execution + +From repo root: + +```bash +./bin/fn fn/rewrite/test_harness.fn +``` + +The harness prints each sample and a transformed result. By default, intermediate pretty-prints are commented out in the file, but can be re-enabled for debugging pass-by-pass output. + +## Data flow in the harness + +For each non-comment entry in `samples.fn`: + +1. Parse source string with `E.parse` (`expr` IR). +2. `DS.desugar` lowers to `minexpr` and removes/normalizes syntax forms. +3. `C.curry` enforces unary application/lambda shape. +4. `η.reduce` performs eta reduction. +5. `CPS.T_c(..., M.var("□"))` runs CPS conversion with a hole continuation. +6. `β.reduce` contracts lambda applications and handles arity mismatch cases. +7. `OF.fold` applies algebraic and constant simplification. +8. `CC.shared_closure_convert` computes shared closure-converted output. + +Important current behavior: the harness computes step 8 but currently prints step 7 (`g`) by default. + +## The sample corpus + +`fn/rewrite/samples.fn` provides: + +- General language constructs (`let`, `letrec`, lambdas, conditionals, `call/cc`, `amb`, constructors, vectors, namespaces, etc.). +- A large arithmetic/optimization section focused on constant-folding behavior. +- Several explicit η-reduction-focused samples near the end. +- Inline comments as strings beginning with `";"` that the harness prints as section labels. + +Use this corpus first when validating behavioral changes in rewrite passes. + +## Representation split to keep in mind + +- `expr.fn` is intended to broadly mirror `src/lambda.yaml` (LamExp-like shapes in the rewrite prototype). +- `desugar.fn` lowers from `expr.fn` to `minexpr.fn`. +- `minexpr.fn` is intended to broadly mirror `src/minlam.yaml` (MinExp-like reduced forms). +- All subsequent transforms in the main rewrite pipeline operate on `minexpr.fn` values. + +This mirrors the C compiler flow where desugaring lowers `LamExp` to `MinExp` before later optimization/normalization stages. + +Many transform bugs come from accidentally assuming an `expr`/LamExp-like form still exists after desugaring, or from printing/parsing assumptions between these two representations. + +## Key transform files and purpose + +- `desugar.fn`: lowers `expr` to `minexpr`, rewrites `let*`, transforms some constructs to primitive forms, and handles partial/over-application shaping via arity context. +- `curry.fn`: rewrites lambdas and applications into curried form. +- `eta_reduce.fn`: removes `λx.(f x)`-style wrappers when safe (`occurs_in` guard). +- `cps.fn`: CPS transform (`T_k`, `T_c`, and list helper `Ts_k`). +- `beta_reduce.fn`: β-reduction with explicit handling for exact/under/over application. +- `constant_folding.fn`: algebraic simplifier plus recursive fold over `minexpr`. +- `closure-convert.fn`: closure conversion with `flat_closure_convert` (bottom-up) and `shared_closure_convert` (top-down) using `transform.fn` traversal helpers. + +## Relationship to the C compiler pipeline + +Use this rewrite pipeline as a conceptual mirror for C stages, not as an exact 1:1 implementation. + +IR correspondence first: + +- `fn/rewrite/expr.fn` ≈ `src/lambda.yaml` +- `fn/rewrite/minexpr.fn` ≈ `src/minlam.yaml` +- `fn/rewrite/desugar.fn` performs the same broad lowering role as `src/lambda_desugar.c` (`LamExp`-like to `MinExp`-like) + +Useful rough correspondences: + +- `cps.fn` ↔ CPS/continuation strategy used in `src/lambda_cpsTk.c` and `src/lambda_cpsTc.c` +- `beta_reduce.fn` / `eta_reduce.fn` ↔ min-lambda simplification ideas (`src/minlam_*.c`) +- `constant_folding.fn` ↔ arithmetic simplification ideas (see `src/arithmetic.c` and related optimization logic) +- `closure-convert.fn` ↔ closure conversion concepts in lambda conversion/runtime lowering + +When adding or changing a C-stage algorithm, check whether `fn/rewrite` already has a compact version that clarifies intent or edge-case behavior. + +## Agent workflow recommendations + +When asked to modify a rewrite pass: + +1. Start from `test_harness.fn` and identify where in the sequence the pass runs. +2. Add or adjust cases in `samples.fn` close to the affected feature area. +3. Toggle intermediate prints in `test_harness.fn` to isolate first divergent stage. +4. Keep changes constrained to one IR layer (`expr` or `minexpr`) per edit when possible. +5. If a rewrite behavior is intended to inform C code, document the invariant in both places. + +This keeps prototype and production-stage behavior aligned as self-hosting efforts expand. diff --git a/docs/generated/term.md b/docs/generated/term.md new file mode 100644 index 00000000..d43e4229 --- /dev/null +++ b/docs/generated/term.md @@ -0,0 +1,20 @@ +# term + +Specific arithmetic structures for performing constant folding. + +```mermaid +flowchart LR +TermOp --left--> Term +TermOp --right--> Term +TermValue --value--> Value +Term --add--> TermOp +Term --sub--> TermOp +Term --mul--> TermOp +Term --div--> TermOp +Term --mod--> TermOp +Term --pow--> TermOp +Term --num--> TermValue +Term --other--> MinExp +``` + +> Generated from src/term.yaml by tools/generate.py diff --git a/fn/listutils.fn b/fn/listutils.fn index afb236cd..42199a9a 100644 --- a/fn/listutils.fn +++ b/fn/listutils.fn @@ -276,6 +276,11 @@ fn pairmap(l, r) { fn (#(ls, rs)) { #(l(ls), r(rs)) } } +// "&&" takes two functions and returns a function that accepts a 2-tuple, applies +// the first function to the first element and the second function to the second +// element, and returns a 2-tuple of the results. It is particularily useful for +// mapping over a zipped list without having to unzip and re-zip. +// example: zipped |> identity && add(2) export operator "_&&_" left 9 pairmap; // last: list(#a) -> #a diff --git a/fn/rewrite/README.md b/fn/rewrite/README.md index bd6da66a..98f6126b 100644 --- a/fn/rewrite/README.md +++ b/fn/rewrite/README.md @@ -4,6 +4,8 @@ An exploratory sub-project to investigate re-writing F♯ in F♯. For this to b Even if it doesn't pan out, this is still useful as it provides concise reference implementations of some of the core algorithms which can inform the C implementation. +For agent-oriented guidance on the rewrite prototyping/self-hosting workflow (`test_harness.fn`, pass ordering, and `samples.fn` usage), see [`docs/agents/rewrite-self-hosting-guide.md`](../../docs/agents/rewrite-self-hosting-guide.md). + * [`alphaconvert.fn`](alphaconvert.fn) - ɑ-conversion algorithm over `expr`. * [`expr.fn`](expr.fn) - A set of types intended to replicate the LamExp structures in [`lambda.yaml`](../../src/lambda.yaml). Only used by a subset of the other packages, would be nice to expand its usage. * [`ceskf.fn`](ceskf.fn) - The core CESKF machine. diff --git a/fn/rewrite/constant_folding.fn b/fn/rewrite/constant_folding.fn index 28250f4e..f62d17b0 100644 --- a/fn/rewrite/constant_folding.fn +++ b/fn/rewrite/constant_folding.fn @@ -4,6 +4,8 @@ namespace link "minexpr.fn" as M; link "../listutils.fn" as list; +import list operator "_|>_"; // map +import list operator "_&&_"; // (#a -> #b) -> (#c -> #d) -> #(#a, #c) -> #(#b, #d) fn simplify (e) { let @@ -99,9 +101,12 @@ fn simplify (e) { (add(sub(x, num(a)), sub(y, num(b)))) | (add(sub(y, num(b)), sub(x, num(a)))) { S(sub(add(x, y), num(a + b))) } (add(a, a)) { S(mul(num(2), a)) } + (add(div(x, d), div(y, d))) | + (add(div(y, d), div(x, d))) { S(div(add(x, y), d)) } (sub(num(a), num(b))) { num(a - b) } (sub(a, num(0))) { a } (sub(x, x)) { num(0) } + (sub(div(x, d), div(y, d))) { S(div(sub(x, y), d)) } (sub(num(a), add(num(b), x))) | (sub(num(a), add(x, num(b)))) { S(sub(num(a - b), x)) } (sub(add(num(a), x), num(b))) | @@ -177,6 +182,10 @@ fn simplify (e) { (mul(div(num(a), x), div(num(b), y))) { S(div(num(a * b), mul(x, y))) } (div(div(x, num(a)), div(y, num(b)))) { S(mul(div(x, y), num(b / a))) } (div(div(num(a), x), div(num(b), y))) { S(mul(num(a / b), div(y, x))) } + (div(mul(k, x), mul(k, y))) | + (div(mul(x, k), mul(k, y))) | + (div(mul(k, x), mul(y, k))) | + (div(mul(x, k), mul(y, k))) { S(div(x, y)) } (mod(num(a), num(b))) { num(a % b) } (mod(num(0), _)) { num(0) } (mod(_, num(1))) { num(0) } @@ -205,7 +214,7 @@ fn fold { // apply(expr, list(expr)) { let f = fold(fun); - a = list.map(fold, args); + a = args |> fold; in switch (f) { (M.primop(_)) { @@ -236,11 +245,7 @@ fn fold { (M.cond_expr(test, branches)) { // cond_expr(expr, list(#(expr, expr))) - let #(vals, results) = list.unzip(branches); - in - M.cond_expr(fold(test), - list.zip(list.map(fold, vals), - list.map(fold, results))) + M.cond_expr(fold(test), branches |> fold && fold) } (M.if_expr(exprc, exprt, exprf)) { @@ -268,11 +273,7 @@ fn fold { (M.letrec_expr(bindings, expr)) { // letrec_expr(list(#(string, expr)), expr) - let #(vars, exprs) = list.unzip(bindings); - newexprs = list.map(fold, exprs); - newbindings = list.zip(vars, newexprs); - in - M.letrec_expr(newbindings, fold(expr)) + M.letrec_expr(bindings |> identity && fold, fold(expr)) } (M.lookup(name, index, expr)) { @@ -282,25 +283,22 @@ fn fold { (M.make_vec(size, args)) { // make_vec(number, list(expr)) - M.make_vec(size, list.map(fold, args)) + M.make_vec(size, args |> fold) } (M.match_cases(test, cases)) { // match_cases(expr, list(#(list(number), expr))) - let #(vals, results) = list.unzip(cases); - in - M.match_cases(fold(test), - list.zip(vals, list.map(fold, results))) + M.match_cases(fold(test), cases |> identity && fold) } (M.namespaces(exprs)) { // namespaces(list(expr)) - M.namespaces(list.map(fold, exprs)) + M.namespaces(exprs |> fold) } (M.sequence(exprs)) { // sequence(list(expr)) - M.sequence(list.map(fold, exprs)) + M.sequence(exprs |> fold) } (x) { diff --git a/fn/rewrite/samples.fn b/fn/rewrite/samples.fn index ecbb9707..01d5419d 100644 --- a/fn/rewrite/samples.fn +++ b/fn/rewrite/samples.fn @@ -398,4 +398,9 @@ namespace "(λ (x) ((h p) x))", "(λ (y) ((λ (x) (g x)) y))", "(λ (y) ((λ (x) ((h p) x)) y))", + + ";--- NEW simplification targets ---", + "(+ (/ x 2) (/ y 2))", + "(- (/ x 2) (/ y 2))", + "(/ (* k x) (* k y))", ]}; diff --git a/fn/rewrite/subst.fn b/fn/rewrite/subst.fn index 2710d817..acd62612 100644 --- a/fn/rewrite/subst.fn +++ b/fn/rewrite/subst.fn @@ -2,6 +2,7 @@ namespace link "minexpr.fn" as M; link "../dictutils.fn" as D; link "../listutils.fn" as list; + import list operators; // substitute: D.Dict(string, M.expr) -> M.expr -> M.expr fn substitute(c, e) { @@ -16,12 +17,12 @@ namespace // apply_closure(expr, list(expr)) (M.apply_closure(f, args)) { - M.apply_closure(substitute(c, f), list.map(substitute(c), args)) + M.apply_closure(substitute(c, f), args |> substitute(c)) } // apply(expr, list(expr)) (M.apply(fun, args)) { - M.apply(substitute(c, fun), list.map(substitute(c), args)) + M.apply(substitute(c, fun), args |> substitute(c)) } (x = M.back_expr) | @@ -41,10 +42,8 @@ namespace // cond_expr(expr, list(#(expr, expr))) (M.cond_expr(test, branches)) { - let #(vals, results) = list.unzip(branches); - in M.cond_expr(substitute(c, test), - list.zip(list.map(substitute(c), vals), - list.map(substitute(c), results))) + M.cond_expr(substitute(c, test), + branches |> substitute(c) && substitute(c)) } // if_expr(expr, expr, expr) @@ -73,7 +72,7 @@ namespace // make_env(list(#(string, expr))) (M.make_env(bindings)) { - M.make_env(list.map(fn (#(v, e)) { #(v, substitute(c, e)) }, bindings)) + M.make_env(bindings |> identity && substitute(c)) } // env_ref(expr, string) @@ -83,7 +82,7 @@ namespace // letrec_expr(list(#(string, expr)), expr) (M.letrec_expr(bindings, expr)) { - let c2 = D.delete_list(list.map(fn (#(var, val)) { var }, bindings), c); + let c2 = D.delete_list(bindings |> fn (#(var, val)) { var }, c); in M.letrec_expr(bindings, substitute(c2, expr)) // new environment } @@ -94,25 +93,25 @@ namespace // make_vec(number, list(expr)) (M.make_vec(size, args)) { - M.make_vec(size, list.map(substitute(c), args)) + M.make_vec(size, args |> substitute(c)) } // match_cases(expr, list(#(list(number), expr))) (M.match_cases(test, cases)) { - let #(vals, results) = list.unzip(cases); + let #(vals, results) = unzip cases; in M.match_cases(substitute(c, test), - list.zip(vals, list.map(substitute(c), results))) + vals zip (results |> substitute(c))) } // namespaces(list(expr)) (M.namespaces(exprs)) { - M.namespaces(list.map(substitute(c), exprs)) + M.namespaces(exprs |> substitute(c)) } // sequence(list(expr)) (M.sequence(exprs)) { - M.sequence(list.map(substitute(c), exprs)) + M.sequence(exprs |> substitute(c)) } // var(string) diff --git a/scratch/probe_complex_rational.fn b/scratch/probe_complex_rational.fn new file mode 100644 index 00000000..0539b640 --- /dev/null +++ b/scratch/probe_complex_rational.fn @@ -0,0 +1,11 @@ +let + fn probe() { + let + ratio = 1 / 2; + complex = 5 + 7i; + mixed = 1 / (5 + 7i); + in + [ratio, complex, mixed] + } +in + probe() diff --git a/scratch/probe_fold.fn b/scratch/probe_fold.fn new file mode 100644 index 00000000..06ce7811 --- /dev/null +++ b/scratch/probe_fold.fn @@ -0,0 +1,13 @@ +let + fn probe() { + let + a = 1 + 2; + b = (2 / 3) + (4 / 5); + c = (5 + 7i) - 7i; + d = (2 * 3) + (4 * 5); + e = (1 / 2) * (3 / 4); + in + [a, b, c, d, e] + } +in + probe() diff --git a/src/anf_normalize.c b/src/anf_normalize.c index c47bd740..32332be6 100644 --- a/src/anf_normalize.c +++ b/src/anf_normalize.c @@ -339,6 +339,7 @@ static AnfExp *normalizeSequence(MinExprList *sequence, AnfExp *tail) { cant_happen("empty sequence in normalizeSequence"); } if (sequence->next == NULL) { + LEAVE(normalizeSequence); return normalize(sequence->exp, tail); } AnfExp *next = normalizeSequence(sequence->next, tail); diff --git a/src/arithmetic.c b/src/arithmetic.c index 53a97b60..80f35e34 100644 --- a/src/arithmetic.c +++ b/src/arithmetic.c @@ -16,20 +16,20 @@ * along with this program. If not, see . */ -#include #include +#include -#include "common.h" -#include "bigint.h" #include "arithmetic.h" +#include "bigint.h" #include "cekf.h" +#include "common.h" #include "debug.h" #include "types.h" #ifdef DEBUG_ARITHMETIC -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif // indexes into vec @@ -47,30 +47,30 @@ #define IS_STDINT_IMAG(x) ((x).type == VALUE_TYPE_STDINT_IMAG) #define IS_INT(x) (IS_STDINT(x) || IS_BIGINT(x)) #define IS_IMAGINT(x) (IS_STDINT_IMAG(x) || IS_BIGINT_IMAG(x)) -#define IS_RATIONAL_OR_INT(x) ((x).type == VALUE_TYPE_RATIONAL || IS_INT(x)) +#define IS_RATIONAL_OR_INT(x) (IS_RATIONAL(x) || IS_INT(x)) #define IS_REAL(x) (IS_RATIONAL_OR_INT(x) || IS_IRRATIONAL(x)) #define IS_NOT_REAL(x) (!IS_REAL(x)) #ifdef SAFETY_CHECKS -# define ASSERT_COMPLEX(x) ASSERT(IS_COMPLEX(x)) -# define ASSERT_RATIONAL(x) ASSERT(IS_RATIONAL(x)) -# define ASSERT_IRRATIONAL(x) ASSERT(IS_IRRATIONAL(x)) -# define ASSERT_BIGINT(x) ASSERT(IS_BIGINT(x)) -# define ASSERT_STDINT(x) ASSERT(IS_STDINT(x)) -# define ASSERT_INT(x) ASSERT(IS_INT(x)) -# define ASSERT_RATIONAL_OR_INT(x) ASSERT(IS_RATIONAL_OR_INT(x)) -# define ASSERT_REAL(x) ASSERT(IS_REAL(x)) -# define ASSERT_NOT_REAL(x) ASSERT(IS_NOT_REAL(x)) +#define ASSERT_COMPLEX(x) ASSERT(IS_COMPLEX(x)) +#define ASSERT_RATIONAL(x) ASSERT(IS_RATIONAL(x)) +#define ASSERT_IRRATIONAL(x) ASSERT(IS_IRRATIONAL(x)) +#define ASSERT_BIGINT(x) ASSERT(IS_BIGINT(x)) +#define ASSERT_STDINT(x) ASSERT(IS_STDINT(x)) +#define ASSERT_INT(x) ASSERT(IS_INT(x)) +#define ASSERT_RATIONAL_OR_INT(x) ASSERT(IS_RATIONAL_OR_INT(x)) +#define ASSERT_REAL(x) ASSERT(IS_REAL(x)) +#define ASSERT_NOT_REAL(x) ASSERT(IS_NOT_REAL(x)) #else -# define ASSERT_COMPLEX(x) -# define ASSERT_RATIONAL(x) -# define ASSERT_IRRATIONAL(x) -# define ASSERT_BIGINT(x) -# define ASSERT_STDINT(x) -# define ASSERT_INT(x) -# define ASSERT_RATIONAL_OR_INT(x) -# define ASSERT_REAL(x) -# define ASSERT_NOT_REAL(x) +#define ASSERT_COMPLEX(x) +#define ASSERT_RATIONAL(x) +#define ASSERT_IRRATIONAL(x) +#define ASSERT_BIGINT(x) +#define ASSERT_STDINT(x) +#define ASSERT_INT(x) +#define ASSERT_RATIONAL_OR_INT(x) +#define ASSERT_REAL(x) +#define ASSERT_NOT_REAL(x) #endif typedef Value (*ValOp)(Value, Value); @@ -79,15 +79,9 @@ typedef Value (*ParameterizedBinOp)(IntegerBinOp, Value, Value); static bool arithmetic_initialized = false; -static Value One = { - .type = VALUE_TYPE_STDINT, - .val = VALUE_VAL_STDINT(1) -}; +static Value One = {.type = VALUE_TYPE_STDINT, .val = VALUE_VAL_STDINT(1)}; -static Value Zero = { - .type = VALUE_TYPE_STDINT, - .val = VALUE_VAL_STDINT(0) -}; +static Value Zero = {.type = VALUE_TYPE_STDINT, .val = VALUE_VAL_STDINT(0)}; static Value ratSimplify(Value numerator, Value denominator); static Value comMag(Value v); @@ -96,80 +90,76 @@ static Value imag_to_real(Value v); // be careful with this, printing a bigint can cause a GC // so make sure everything is protected before calling. -static void ppNumber(Value number)__attribute__((unused)); +static void ppNumber(Value number) __attribute__((unused)); /** * Pretty print a number for debugging */ static void ppNumber(Value number) { switch (number.type) { - case VALUE_TYPE_STDINT: - eprintf("%d", number.val.stdint); - break; - case VALUE_TYPE_STDINT_IMAG: - eprintf("%di", number.val.stdint); - break; - case VALUE_TYPE_BIGINT: - eprintf("["); - fprintBigInt(errout, number.val.bigint); - eprintf("]"); - break; - case VALUE_TYPE_BIGINT_IMAG: - eprintf("["); - fprintBigInt(errout, number.val.bigint); - eprintf("]i"); - break; - case VALUE_TYPE_RATIONAL: - ppNumber(number.val.vec->entries[0]); - eprintf("/"); - ppNumber(number.val.vec->entries[1]); - break; - case VALUE_TYPE_RATIONAL_IMAG: - eprintf("("); - ppNumber(number.val.vec->entries[0]); - eprintf("/"); - ppNumber(number.val.vec->entries[1]); - eprintf(")i"); - break; - case VALUE_TYPE_IRRATIONAL: - eprintf("%f", number.val.irrational); - break; - case VALUE_TYPE_IRRATIONAL_IMAG: - eprintf("%fi", number.val.irrational); - break; - case VALUE_TYPE_COMPLEX: - ppNumber(number.val.vec->entries[0]); - eprintf("+"); - ppNumber(number.val.vec->entries[1]); - break; - default: - eprintf("??? %d ???", number.type); + case VALUE_TYPE_STDINT: + eprintf("%d", number.val.stdint); + break; + case VALUE_TYPE_STDINT_IMAG: + eprintf("%di", number.val.stdint); + break; + case VALUE_TYPE_BIGINT: + eprintf("["); + fprintBigInt(errout, number.val.bigint); + eprintf("]"); + break; + case VALUE_TYPE_BIGINT_IMAG: + eprintf("["); + fprintBigInt(errout, number.val.bigint); + eprintf("]i"); + break; + case VALUE_TYPE_RATIONAL: + ppNumber(number.val.vec->entries[0]); + eprintf("/"); + ppNumber(number.val.vec->entries[1]); + break; + case VALUE_TYPE_RATIONAL_IMAG: + eprintf("("); + ppNumber(number.val.vec->entries[0]); + eprintf("/"); + ppNumber(number.val.vec->entries[1]); + eprintf(")i"); + break; + case VALUE_TYPE_IRRATIONAL: + eprintf("%f", number.val.irrational); + break; + case VALUE_TYPE_IRRATIONAL_IMAG: + eprintf("%fi", number.val.irrational); + break; + case VALUE_TYPE_COMPLEX: + ppNumber(number.val.vec->entries[0]); + eprintf("+"); + ppNumber(number.val.vec->entries[1]); + break; + default: + eprintf("??? %d ???", number.type); } } /** * Get the real part of a complex number - * + * * @param v the complex value * @return the real part */ -static inline Value realPart(Value v) { - return v.val.vec->entries[REAL]; -} +static inline Value realPart(Value v) { return v.val.vec->entries[REAL]; } /** * Get the imaginary part of a complex number - * + * * @param v the complex value * @return the imaginary part */ -static inline Value imagPart(Value v) { - return v.val.vec->entries[IMAG]; -} +static inline Value imagPart(Value v) { return v.val.vec->entries[IMAG]; } /** * Extract real and imaginary parts from a complex argument - * + * * @param a pointer to store real part * @param b pointer to store imaginary part * @param v the complex value to extract from @@ -182,7 +172,7 @@ static inline void extractFromComplexArg(Value *a, Value *b, Value v) { /** * Extract real and imaginary parts from two complex arguments - * + * * @param a pointer to store real part of left * @param b pointer to store imaginary part of left * @param c pointer to store real part of right @@ -190,14 +180,15 @@ static inline void extractFromComplexArg(Value *a, Value *b, Value v) { * @param left the left complex value * @param right the right complex value */ -static inline void extractFromComplexArgs(Value *a, Value *b, Value *c, Value *d, Value left, Value right) { +static inline void extractFromComplexArgs(Value *a, Value *b, Value *c, + Value *d, Value left, Value right) { extractFromComplexArg(a, b, left); extractFromComplexArg(c, d, right); } /** * Get the denominator part of a rational number - * + * * @param v the rational value * @return the denominator part */ @@ -207,7 +198,7 @@ static inline Value denominatorPart(Value v) { /** * Get the numerator part of a rational number - * + * * @param v the rational value * @return the numerator part */ @@ -217,7 +208,7 @@ static inline Value numeratorPart(Value v) { /** * Create a rational value from numerator and denominator - * + * * @param numerator the numerator value * @param denominator the denominator value * @return the rational value @@ -233,7 +224,7 @@ static Value ratValue(Value numerator, Value denominator) { /** * Create a complex value from real and imaginary parts - * + * * @param real the real part * @param imag the imaginary part * @return the complex value @@ -249,7 +240,7 @@ static Value comValue(Value real, Value imag) { /** * Convert an integer value to an irrational value - * + * * @param integer the integer value * @return the irrational value */ @@ -264,7 +255,7 @@ static Value int_to_irrational(Value integer) { /** * Convert a rational value to an irrational value - * + * * @param rational the rational value * @return the irrational value */ @@ -274,7 +265,8 @@ static Value rational_to_irrational(Value rational) { Value numerator = int_to_irrational(num); Value denom = denominatorPart(rational); Value denominator = int_to_irrational(denom); - return value_Irrational(numerator.val.irrational / denominator.val.irrational); + return value_Irrational(numerator.val.irrational / + denominator.val.irrational); } /** @@ -285,15 +277,15 @@ static Value rational_to_irrational(Value rational) { */ static Value to_irrational(Value v) { switch (v.type) { - case VALUE_TYPE_STDINT: - case VALUE_TYPE_BIGINT: - return int_to_irrational(v); - case VALUE_TYPE_RATIONAL: - return rational_to_irrational(v); - case VALUE_TYPE_IRRATIONAL: - return v; - default: - cant_happen("invalid type %s", valueTypeName(v.type)); + case VALUE_TYPE_STDINT: + case VALUE_TYPE_BIGINT: + return int_to_irrational(v); + case VALUE_TYPE_RATIONAL: + return rational_to_irrational(v); + case VALUE_TYPE_IRRATIONAL: + return v; + default: + cant_happen("invalid type %s", valueTypeName(v.type)); } return v; } @@ -312,7 +304,7 @@ static Value int_to_rational(Value integer) { /** * Convert a bigint value to an irrational value - * + * * @param v the bigint value * @return the irrational value */ @@ -323,7 +315,7 @@ static Value bigint_to_irrational(Value v) { /** * Convert a standard integer value to a bigint value - * + * * @param v the standard integer value * @return the bigint value */ @@ -334,7 +326,7 @@ static Value int_to_bigint(Value v) { /** * Convert a real value to a complex value (x + 0i) - * + * * @param real the real value * @return the complex value */ @@ -345,7 +337,7 @@ static Value real_to_complex(Value real) { /** * Convert an imaginary value to a complex value (0 + xi) - * + * * @param imag the imaginary value * @return the complex value */ @@ -356,79 +348,81 @@ static Value imag_to_complex(Value imag) { /** * Convert a value to a complex value - * + * * @param v the value to convert * @return the complex value */ static Value to_complex(Value v) { switch (v.type) { - case VALUE_TYPE_STDINT: - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL: - return real_to_complex(v); - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - return imag_to_complex(v); - case VALUE_TYPE_COMPLEX: - return v; - default: - cant_happen("invalid type %s", valueTypeName(v.type)); + case VALUE_TYPE_STDINT: + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: + return real_to_complex(v); + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + return imag_to_complex(v); + case VALUE_TYPE_COMPLEX: + return v; + default: + cant_happen("invalid type %s", valueTypeName(v.type)); } } /** * Destructively cast imaginary to real for basic arithmetic. - * It is the responsiblity of the caller to ensure that the imaginary part is zero. - * + * It is the responsiblity of the caller to ensure that the imaginary part is + * zero. + * * @param v the imaginary value * @return the real value */ static Value imag_to_real(Value v) { switch (v.type) { - case VALUE_TYPE_STDINT_IMAG: - v.type = VALUE_TYPE_STDINT; - break; - case VALUE_TYPE_BIGINT_IMAG: - v.type = VALUE_TYPE_BIGINT; - break; - case VALUE_TYPE_RATIONAL_IMAG: - v.type = VALUE_TYPE_RATIONAL; - break; - case VALUE_TYPE_IRRATIONAL_IMAG: - v.type = VALUE_TYPE_IRRATIONAL; - break; - default: - cant_happen("invalid imaginary type %s", valueTypeName(v.type)); + case VALUE_TYPE_STDINT_IMAG: + v.type = VALUE_TYPE_STDINT; + break; + case VALUE_TYPE_BIGINT_IMAG: + v.type = VALUE_TYPE_BIGINT; + break; + case VALUE_TYPE_RATIONAL_IMAG: + v.type = VALUE_TYPE_RATIONAL; + break; + case VALUE_TYPE_IRRATIONAL_IMAG: + v.type = VALUE_TYPE_IRRATIONAL; + break; + default: + cant_happen("invalid imaginary type %s", valueTypeName(v.type)); } return v; } /** * Destructively cast real to imaginary for basic arithmetic. - * It is the responsiblity of the caller to ensure that the imaginary part is already zero. - * + * It is the responsiblity of the caller to ensure that the imaginary part is + * already zero. + * * @param v the real value * @return the imaginary value */ static Value real_to_imag(Value v) { switch (v.type) { - case VALUE_TYPE_STDINT: - v.type = VALUE_TYPE_STDINT_IMAG; - break; - case VALUE_TYPE_BIGINT: - v.type = VALUE_TYPE_BIGINT_IMAG; - break; - case VALUE_TYPE_RATIONAL: - v.type = VALUE_TYPE_RATIONAL_IMAG; - break; - case VALUE_TYPE_IRRATIONAL: - v.type = VALUE_TYPE_IRRATIONAL_IMAG; - break; - default: - cant_happen("invalid real type %s", valueTypeName(v.type)); + case VALUE_TYPE_STDINT: + v.type = VALUE_TYPE_STDINT_IMAG; + break; + case VALUE_TYPE_BIGINT: + v.type = VALUE_TYPE_BIGINT_IMAG; + break; + case VALUE_TYPE_RATIONAL: + v.type = VALUE_TYPE_RATIONAL_IMAG; + break; + case VALUE_TYPE_IRRATIONAL: + v.type = VALUE_TYPE_IRRATIONAL_IMAG; + break; + default: + cant_happen("invalid real type %s", valueTypeName(v.type)); } return v; } @@ -452,7 +446,7 @@ static Integer rec_to_polar(Value com, Value *r, Value *theta) { /** * Determine if an integer value is negative - * + * * @param v the integer value * @return true if negative, false otherwise */ @@ -467,7 +461,7 @@ static bool intIsNeg(Value v) { /** * Determine if a rational value is negative - * + * * @param v the rational value * @return true if negative, false otherwise */ @@ -478,7 +472,7 @@ static bool ratIsNeg(Value v) { /** * Determine if an irrational value is negative - * + * * @param v the irrational value * @return true if negative, false otherwise */ @@ -489,27 +483,27 @@ static bool irratIsNeg(Value v) { /** * Determine if any non-complex value is negative - * + * * @param v the value * @return true if negative, false otherwise */ static bool isNeg(Value v) { switch (v.type) { - case VALUE_TYPE_STDINT: - case VALUE_TYPE_BIGINT: - return intIsNeg(v); - case VALUE_TYPE_RATIONAL: - return ratIsNeg(v); - case VALUE_TYPE_IRRATIONAL: - return irratIsNeg(v); - default: - cant_happen("invalid real type %s", valueTypeName(v.type)); + case VALUE_TYPE_STDINT: + case VALUE_TYPE_BIGINT: + return intIsNeg(v); + case VALUE_TYPE_RATIONAL: + return ratIsNeg(v); + case VALUE_TYPE_IRRATIONAL: + return irratIsNeg(v); + default: + cant_happen("invalid real type %s", valueTypeName(v.type)); } } /** * Determine if an integer value is even - * + * * @param v the integer value * @return true if even, false otherwise */ @@ -532,191 +526,198 @@ static bool intIsEven(Value v) { static Integer coerce(Value *left, Value *right, int *save) { *save = PROTECT(NULL); - switch(left->type) { + switch (left->type) { + case VALUE_TYPE_RATIONAL: + switch (right->type) { case VALUE_TYPE_RATIONAL: - switch(right->type) { - case VALUE_TYPE_RATIONAL: - return VALUE_TYPE_RATIONAL; - case VALUE_TYPE_IRRATIONAL: - *left = rational_to_irrational(*left); - return VALUE_TYPE_IRRATIONAL; - case VALUE_TYPE_BIGINT: - *right = int_to_rational(*right); - *save = protectValue(*right); - return VALUE_TYPE_RATIONAL; - case VALUE_TYPE_STDINT: - *right = int_to_rational(*right); - *save = protectValue(*right); - return VALUE_TYPE_RATIONAL; - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - *left = real_to_complex(*left); - *save = protectValue(*left); - *right = imag_to_complex(*right); - protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_COMPLEX: - *left = real_to_complex(*left); - *save = protectValue(*left); - return VALUE_TYPE_COMPLEX; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right->type)); - } - break; + return VALUE_TYPE_RATIONAL; case VALUE_TYPE_IRRATIONAL: - switch(right->type) { - case VALUE_TYPE_RATIONAL: - *right = rational_to_irrational(*right); - return VALUE_TYPE_IRRATIONAL; - case VALUE_TYPE_IRRATIONAL: - return VALUE_TYPE_IRRATIONAL; - case VALUE_TYPE_BIGINT: - *right = bigint_to_irrational(*right); - return VALUE_TYPE_IRRATIONAL; - case VALUE_TYPE_STDINT: - *right = int_to_irrational(*right); - return VALUE_TYPE_IRRATIONAL; - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - *left = real_to_complex(*left); - *save = protectValue(*left); - *right = imag_to_complex(*right); - protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_COMPLEX: - *left = real_to_complex(*left); - *save = protectValue(*left); - return VALUE_TYPE_COMPLEX; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right->type)); - } - break; + *left = rational_to_irrational(*left); + return VALUE_TYPE_IRRATIONAL; case VALUE_TYPE_BIGINT: - switch(right->type) { - case VALUE_TYPE_RATIONAL: - *left = int_to_rational(*left); - return VALUE_TYPE_RATIONAL; - case VALUE_TYPE_IRRATIONAL: - *left = bigint_to_irrational(*left); - return VALUE_TYPE_IRRATIONAL; - case VALUE_TYPE_BIGINT: - return VALUE_TYPE_BIGINT; - case VALUE_TYPE_STDINT: - *right = int_to_bigint(*right); - *save = protectValue(*right); - return VALUE_TYPE_BIGINT; - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - *left = real_to_complex(*left); - *save = protectValue(*left); - *right = imag_to_complex(*right); - protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_COMPLEX: - *left = real_to_complex(*left); - *save = protectValue(*left); - return VALUE_TYPE_COMPLEX; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right->type)); - } - break; + *right = int_to_rational(*right); + *save = protectValue(*right); + return VALUE_TYPE_RATIONAL; case VALUE_TYPE_STDINT: - switch(right->type) { - case VALUE_TYPE_RATIONAL: - *left = int_to_rational(*left); - return VALUE_TYPE_RATIONAL; - case VALUE_TYPE_IRRATIONAL: - *left = int_to_irrational(*left); - return VALUE_TYPE_IRRATIONAL; - case VALUE_TYPE_BIGINT: - *left = int_to_bigint(*left); - return VALUE_TYPE_BIGINT; - case VALUE_TYPE_STDINT: - return VALUE_TYPE_STDINT; - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - *left = real_to_complex(*left); - *save = protectValue(*left); - *right = imag_to_complex(*right); - protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_COMPLEX: - *left = real_to_complex(*left); - *save = protectValue(*left); - return VALUE_TYPE_COMPLEX; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right->type)); - } - break; + *right = int_to_rational(*right); + *save = protectValue(*right); + return VALUE_TYPE_RATIONAL; case VALUE_TYPE_STDINT_IMAG: case VALUE_TYPE_BIGINT_IMAG: case VALUE_TYPE_RATIONAL_IMAG: case VALUE_TYPE_IRRATIONAL_IMAG: - switch(right->type) { - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL: - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - *left = imag_to_complex(*left); - *save = protectValue(*left); - *right = real_to_complex(*right); - protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - *left = imag_to_complex(*left); - *save = protectValue(*left); - *right = imag_to_complex(*right); - protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_COMPLEX: - *left = imag_to_complex(*left); - *save = protectValue(*left); - return VALUE_TYPE_COMPLEX; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right->type)); - } - break; + *left = real_to_complex(*left); + *save = protectValue(*left); + *right = imag_to_complex(*right); + protectValue(*right); + return VALUE_TYPE_COMPLEX; case VALUE_TYPE_COMPLEX: - switch(right->type) { - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL: - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - *right = real_to_complex(*right); - *save = protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - *right = imag_to_complex(*right); - *save = protectValue(*right); - return VALUE_TYPE_COMPLEX; - case VALUE_TYPE_COMPLEX: - return VALUE_TYPE_COMPLEX; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right->type)); - } - break; + *left = real_to_complex(*left); + *save = protectValue(*left); + return VALUE_TYPE_COMPLEX; default: - cant_happen("unrecognised left number type %s", valueTypeName(left->type)); + cant_happen("unrecognised right number type %s", + valueTypeName(right->type)); + } + break; + case VALUE_TYPE_IRRATIONAL: + switch (right->type) { + case VALUE_TYPE_RATIONAL: + *right = rational_to_irrational(*right); + return VALUE_TYPE_IRRATIONAL; + case VALUE_TYPE_IRRATIONAL: + return VALUE_TYPE_IRRATIONAL; + case VALUE_TYPE_BIGINT: + *right = bigint_to_irrational(*right); + return VALUE_TYPE_IRRATIONAL; + case VALUE_TYPE_STDINT: + *right = int_to_irrational(*right); + return VALUE_TYPE_IRRATIONAL; + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + *left = real_to_complex(*left); + *save = protectValue(*left); + *right = imag_to_complex(*right); + protectValue(*right); + return VALUE_TYPE_COMPLEX; + case VALUE_TYPE_COMPLEX: + *left = real_to_complex(*left); + *save = protectValue(*left); + return VALUE_TYPE_COMPLEX; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right->type)); + } + break; + case VALUE_TYPE_BIGINT: + switch (right->type) { + case VALUE_TYPE_RATIONAL: + *left = int_to_rational(*left); + return VALUE_TYPE_RATIONAL; + case VALUE_TYPE_IRRATIONAL: + *left = bigint_to_irrational(*left); + return VALUE_TYPE_IRRATIONAL; + case VALUE_TYPE_BIGINT: + return VALUE_TYPE_BIGINT; + case VALUE_TYPE_STDINT: + *right = int_to_bigint(*right); + *save = protectValue(*right); + return VALUE_TYPE_BIGINT; + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + *left = real_to_complex(*left); + *save = protectValue(*left); + *right = imag_to_complex(*right); + protectValue(*right); + return VALUE_TYPE_COMPLEX; + case VALUE_TYPE_COMPLEX: + *left = real_to_complex(*left); + *save = protectValue(*left); + return VALUE_TYPE_COMPLEX; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right->type)); + } + break; + case VALUE_TYPE_STDINT: + switch (right->type) { + case VALUE_TYPE_RATIONAL: + *left = int_to_rational(*left); + return VALUE_TYPE_RATIONAL; + case VALUE_TYPE_IRRATIONAL: + *left = int_to_irrational(*left); + return VALUE_TYPE_IRRATIONAL; + case VALUE_TYPE_BIGINT: + *left = int_to_bigint(*left); + return VALUE_TYPE_BIGINT; + case VALUE_TYPE_STDINT: + return VALUE_TYPE_STDINT; + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + *left = real_to_complex(*left); + *save = protectValue(*left); + *right = imag_to_complex(*right); + protectValue(*right); + return VALUE_TYPE_COMPLEX; + case VALUE_TYPE_COMPLEX: + *left = real_to_complex(*left); + *save = protectValue(*left); + return VALUE_TYPE_COMPLEX; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right->type)); + } + break; + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + switch (right->type) { + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + *left = imag_to_complex(*left); + *save = protectValue(*left); + *right = real_to_complex(*right); + protectValue(*right); + return VALUE_TYPE_COMPLEX; + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + *left = imag_to_complex(*left); + *save = protectValue(*left); + *right = imag_to_complex(*right); + protectValue(*right); + return VALUE_TYPE_COMPLEX; + case VALUE_TYPE_COMPLEX: + *left = imag_to_complex(*left); + *save = protectValue(*left); + return VALUE_TYPE_COMPLEX; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right->type)); + } + break; + case VALUE_TYPE_COMPLEX: + switch (right->type) { + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + *right = real_to_complex(*right); + *save = protectValue(*right); + return VALUE_TYPE_COMPLEX; + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + *right = imag_to_complex(*right); + *save = protectValue(*right); + return VALUE_TYPE_COMPLEX; + case VALUE_TYPE_COMPLEX: + return VALUE_TYPE_COMPLEX; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right->type)); + } + break; + default: + cant_happen("unrecognised left number type %s", + valueTypeName(left->type)); } } /** * Compare two bigints - * + * * @param left the left bigint value * @param right the right bigint value * @return comparison result @@ -727,7 +728,7 @@ static inline Cmp int_cmp_bb(Value left, Value right) { /** * Compare a big int and a standard integer - * + * * @param left the bigint value * @param right the standard integer value * @return comparison result @@ -738,7 +739,7 @@ static inline Cmp int_cmp_bi(Value left, Value right) { /** * Compare a bigint and an irrational - * + * * @param left the bigint value * @param right the irrational value * @return comparison result @@ -749,7 +750,7 @@ static inline Cmp int_cmp_bf(Value left, Value right) { /** * Compare a standard integer and a bigint - * + * * @param left the standard integer value * @param right the bigint value * @return comparison result @@ -760,33 +761,33 @@ static inline Cmp int_cmp_ib(Value left, Value right) { /** * Compare two standard integers - * + * * @param left the left standard integer value * @param right the right standard integer value * @return comparison result */ static inline Cmp int_cmp_ii(Value left, Value right) { - return left.val.stdint < right.val.stdint ? CMP_LT : - left.val.stdint == right.val.stdint ? CMP_EQ : - CMP_GT; + return left.val.stdint < right.val.stdint ? CMP_LT + : left.val.stdint == right.val.stdint ? CMP_EQ + : CMP_GT; } /** * Compare a standard integer and an irrational - * + * * @param left the standard integer value * @param right the irrational value * @return comparison result */ static inline Cmp int_cmp_if(Value left, Value right) { - return left.val.stdint < right.val.irrational ? CMP_LT : - left.val.stdint == right.val.irrational ? CMP_EQ : - CMP_GT; + return left.val.stdint < right.val.irrational ? CMP_LT + : left.val.stdint == right.val.irrational ? CMP_EQ + : CMP_GT; } /** * Compare an irrational and a bigint - * + * * @param left the irrational value * @param right the bigint value * @return comparison result @@ -797,33 +798,33 @@ static inline Cmp int_cmp_fb(Value left, Value right) { /** * Compare an irrational and a standard integer - * + * * @param left the irrational value * @param right the standard integer value * @return comparison result */ static inline Cmp int_cmp_fi(Value left, Value right) { - return left.val.irrational < right.val.stdint ? CMP_LT : - left.val.irrational == right.val.stdint ? CMP_EQ : - CMP_GT; + return left.val.irrational < right.val.stdint ? CMP_LT + : left.val.irrational == right.val.stdint ? CMP_EQ + : CMP_GT; } /** * Compare two irrationals - * + * * @param left the left irrational value * @param right the right irrational value * @return comparison result */ static inline Cmp int_cmp_ff(Value left, Value right) { - return left.val.irrational < right.val.irrational ? CMP_LT : - left.val.irrational == right.val.irrational ? CMP_EQ : - CMP_GT; + return left.val.irrational < right.val.irrational ? CMP_LT + : left.val.irrational == right.val.irrational ? CMP_EQ + : CMP_GT; } /** * Compare two number values - * + * * @param left the left value * @param right the right value * @return comparison result @@ -832,53 +833,53 @@ static Cmp numCmp(Value left, Value right) { ENTER(numCmp); Cmp res; switch (left.type) { + case VALUE_TYPE_BIGINT: + switch (right.type) { case VALUE_TYPE_BIGINT: - switch (right.type) { - case VALUE_TYPE_BIGINT: - res = int_cmp_bb(left, right); - break; - case VALUE_TYPE_STDINT: - res = int_cmp_bi(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - res = int_cmp_bf(left, right); - break; - default: - cant_happen("invalid number type"); - } + res = int_cmp_bb(left, right); break; case VALUE_TYPE_STDINT: - switch (right.type) { - case VALUE_TYPE_BIGINT: - res = int_cmp_ib(left, right); - break; - case VALUE_TYPE_STDINT: - res = int_cmp_ii(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - res = int_cmp_if(left, right); - break; - default: - cant_happen("invalid number type"); - } + res = int_cmp_bi(left, right); break; case VALUE_TYPE_IRRATIONAL: - switch (right.type) { - case VALUE_TYPE_BIGINT: - res = int_cmp_fb(left, right); - break; - case VALUE_TYPE_STDINT: - res = int_cmp_fi(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - res = int_cmp_ff(left, right); - break; - default: - cant_happen("invalid number type"); - } + res = int_cmp_bf(left, right); break; default: cant_happen("invalid number type"); + } + break; + case VALUE_TYPE_STDINT: + switch (right.type) { + case VALUE_TYPE_BIGINT: + res = int_cmp_ib(left, right); + break; + case VALUE_TYPE_STDINT: + res = int_cmp_ii(left, right); + break; + case VALUE_TYPE_IRRATIONAL: + res = int_cmp_if(left, right); + break; + default: + cant_happen("invalid number type"); + } + break; + case VALUE_TYPE_IRRATIONAL: + switch (right.type) { + case VALUE_TYPE_BIGINT: + res = int_cmp_fb(left, right); + break; + case VALUE_TYPE_STDINT: + res = int_cmp_fi(left, right); + break; + case VALUE_TYPE_IRRATIONAL: + res = int_cmp_ff(left, right); + break; + default: + cant_happen("invalid number type"); + } + break; + default: + cant_happen("invalid number type"); } LEAVE(numCmp); @@ -887,7 +888,7 @@ static Cmp numCmp(Value left, Value right) { /** * Perform safe addition of two integers, promoting to bigint on overflow - * + * * @param a the left integer * @param b the right integer * @return the result value @@ -907,7 +908,7 @@ static Value safe_add(Integer a, Integer b) { /** * Add two integer values, standard or bigint, using safe_add to handle overflow - * + * * @param left the left integer value * @param right the right integer value * @return the result value @@ -949,7 +950,7 @@ static Value intAdd(Value left, Value right) { /** * Perform safe multiplication of two integers, promoting to bigint on overflow - * + * * @param a the left integer * @param b the right integer * @return the result value @@ -968,8 +969,9 @@ static Value safe_mul(Integer a, Integer b) { } /** - * Multiply two integer values, standard or bigint, using safe_mul to handle overflow - * + * Multiply two integer values, standard or bigint, using safe_mul to handle + * overflow + * * @param left the left integer value * @param right the right integer value * @return the result value @@ -1000,7 +1002,7 @@ static Value intMul(Value left, Value right) { protectValue(res); } else { res = safe_mul(left.val.stdint, right.val.stdint); - protectValue(res); + protectValue(res); } } LEAVE(intMul); @@ -1011,7 +1013,7 @@ static Value intMul(Value left, Value right) { /** * Perform safe subtraction of two integers, promoting to bigint on overflow - * + * * @param a the left integer * @param b the right integer * @return the result value @@ -1033,8 +1035,9 @@ static Value safe_sub(Integer a, Integer b) { } /** - * Subtract two integer values, standard or bigint, using safe_sub to handle overflow - * + * Subtract two integer values, standard or bigint, using safe_sub to handle + * overflow + * * @param left the left integer value * @param right the right integer value * @return the result value @@ -1076,7 +1079,7 @@ static Value intSub(Value left, Value right) { /** * Divide two integer values, standard or bigint - * + * * @param left the left integer value * @param right the right integer value * @return the result value @@ -1131,13 +1134,13 @@ static Value basicIntDiv(Value left, Value right) { /** * Perform safe exponentiation of two integers, promoting to bigint on overflow - * + * * @param a the base integer * @param b the exponent integer * @return the result value */ static Value safe_powf(Integer a, Integer b) { - float f = powf((float) a, (float) b); + float f = powf((float)a, (float)b); if (f == HUGE_VALF || f > (float)INT_MAX) { if (b >= 0) { BigInt *big = bigIntFromPower(a, b); @@ -1174,20 +1177,20 @@ static Value safe_powf(Integer a, Integer b) { /** * Attempts to simplify a double into an integer if possible - * + * * @param d the double result * @return the simplified value */ static Value irratSimplify(Double d) { Value res; int save = PROTECT(NULL); - if(fmod(d, 1.0) == 0.0) { + if (fmod(d, 1.0) == 0.0) { if (d > (Double)INT_MAX || d < (Double)INT_MIN) { // FIXME need doubleToBigInt res = value_Irrational(d); protectValue(res); } else { - res = value_Stdint((Integer) d); + res = value_Stdint((Integer)d); protectValue(res); } } else { @@ -1200,7 +1203,7 @@ static Value irratSimplify(Double d) { /** * Raise a real number to a rational power. - * + * * @param base the base value * @param exponent the exponent value * @return the result value @@ -1225,9 +1228,11 @@ static Value realPowRat(Value base, Value exponent) { protectValue(res); } } else if (ratIsNeg(exponent)) { - Value pos = nmul(exponent, value_Stdint(-1)); // make the exponent positive + Value pos = + nmul(exponent, value_Stdint(-1)); // make the exponent positive protectValue(pos); - Value inv = realPowRat(base, pos); // recurse on positive base, positive exponent + Value inv = realPowRat( + base, pos); // recurse on positive base, positive exponent protectValue(inv); res = ndiv(value_Stdint(1), inv); // return the inverse protectValue(res); @@ -1255,7 +1260,8 @@ static Value realPowRat(Value base, Value exponent) { Value fexponent = rational_to_irrational(exponent); protectValue(fexponent); Double result = pow(fbase.val.irrational, fexponent.val.irrational); - IFDEBUG(eprintf("doing pow(%f, %f) = %f", fbase.val.irrational, fexponent.val.irrational, result)); + IFDEBUG(eprintf("doing pow(%f, %f) = %f", fbase.val.irrational, + fexponent.val.irrational, result)); res = irratSimplify(result); protectValue(res); } @@ -1268,7 +1274,7 @@ static Value realPowRat(Value base, Value exponent) { /** * Raise an integer value to an integer or rational power. - * + * * @param left the base value * @param right the exponent value * @return the result value @@ -1280,77 +1286,73 @@ static Value intPow(Value left, Value right) { Value res; int save = PROTECT(NULL); switch (left.type) { - case VALUE_TYPE_BIGINT: - switch (right.type) { - case VALUE_TYPE_BIGINT: { - if (intIsNeg(right)) { - BigInt *pos = copyBigInt(right.val.bigint); - PROTECT(pos); - negateBigInt(pos); - BigInt *bi = powBigInt(left.val.bigint, pos); - PROTECT(bi); - Value denom = value_Bigint(bi); - protectValue(denom); - res = ratValue(value_Stdint(1), denom); - protectValue(res); - } else { - BigInt *bi = powBigInt(left.val.bigint, right.val.bigint); - PROTECT(bi); - res = value_Bigint(bi); - protectValue(res); - } - } - break; - case VALUE_TYPE_STDINT: { - if (right.val.stdint < 0) { - BigInt *bi = powBigIntInt(left.val.bigint, -right.val.stdint); - PROTECT(bi); - Value denom = value_Bigint(bi); - protectValue(denom); - res = ratValue(value_Stdint(1), denom); - protectValue(res); - } else { - BigInt *bi = powBigIntInt(left.val.bigint, right.val.stdint); - PROTECT(bi); - res = value_Bigint(bi); - protectValue(res); - } - } - break; - case VALUE_TYPE_RATIONAL: { - res = realPowRat(left, right); - protectValue(res); - } - break; - default: - cant_happen("invalid rhs arg to intPow %s", valueTypeName(left.type)); + case VALUE_TYPE_BIGINT: + switch (right.type) { + case VALUE_TYPE_BIGINT: { + if (intIsNeg(right)) { + BigInt *pos = copyBigInt(right.val.bigint); + PROTECT(pos); + negateBigInt(pos); + BigInt *bi = powBigInt(left.val.bigint, pos); + PROTECT(bi); + Value denom = value_Bigint(bi); + protectValue(denom); + res = ratValue(value_Stdint(1), denom); + protectValue(res); + } else { + BigInt *bi = powBigInt(left.val.bigint, right.val.bigint); + PROTECT(bi); + res = value_Bigint(bi); + protectValue(res); } - break; - case VALUE_TYPE_STDINT: - switch (right.type) { - case VALUE_TYPE_BIGINT: { - BigInt *bi = powIntBigInt(left.val.stdint, right.val.bigint); - PROTECT(bi); - res = value_Bigint(bi); - protectValue(res); - } - break; - case VALUE_TYPE_STDINT: { - res = safe_powf(left.val.stdint, right.val.stdint); - protectValue(res); - } - break; - case VALUE_TYPE_RATIONAL: { - res = realPowRat(left, right); - protectValue(res); - } - break; - default: - cant_happen("invalid rhs arg to intPow %s", valueTypeName(left.type)); + } break; + case VALUE_TYPE_STDINT: { + if (right.val.stdint < 0) { + BigInt *bi = powBigIntInt(left.val.bigint, -right.val.stdint); + PROTECT(bi); + Value denom = value_Bigint(bi); + protectValue(denom); + res = ratValue(value_Stdint(1), denom); + protectValue(res); + } else { + BigInt *bi = powBigIntInt(left.val.bigint, right.val.stdint); + PROTECT(bi); + res = value_Bigint(bi); + protectValue(res); } - break; + } break; + case VALUE_TYPE_RATIONAL: { + res = realPowRat(left, right); + protectValue(res); + } break; default: - cant_happen("invalid lhs arg to intPow %s", valueTypeName(left.type)); + cant_happen("invalid rhs arg to intPow %s", + valueTypeName(left.type)); + } + break; + case VALUE_TYPE_STDINT: + switch (right.type) { + case VALUE_TYPE_BIGINT: { + BigInt *bi = powIntBigInt(left.val.stdint, right.val.bigint); + PROTECT(bi); + res = value_Bigint(bi); + protectValue(res); + } break; + case VALUE_TYPE_STDINT: { + res = safe_powf(left.val.stdint, right.val.stdint); + protectValue(res); + } break; + case VALUE_TYPE_RATIONAL: { + res = realPowRat(left, right); + protectValue(res); + } break; + default: + cant_happen("invalid rhs arg to intPow %s", + valueTypeName(left.type)); + } + break; + default: + cant_happen("invalid lhs arg to intPow %s", valueTypeName(left.type)); } LEAVE(intPow); IFDEBUG(ppNumber(res)); @@ -1360,7 +1362,7 @@ static Value intPow(Value left, Value right) { /** * Modulus of two integer values, standard or bigint - * + * * @param left the left integer value * @param right the right integer value * @return the result value @@ -1417,33 +1419,33 @@ static Value intMod(Value left, Value right) { /** * Compute the greatest common divisor of two standard integers - * + * * @param a the left integer * @param b the right integer * @return the gcd */ -static Integer gcd (Integer a, Integer b) { +static Integer gcd(Integer a, Integer b) { if (a < 0) { a = -a; } if (b < 0) { b = -b; } - Integer i = 0, min_num = a, gcd = 1; - if (a > b) { - min_num = b; - } - for (i = 1; i <= min_num; i++) { - if (a % i == 0 && b % i == 0) { - gcd = i; - } - } - return gcd; + Integer i = 0, min_num = a, gcd = 1; + if (a > b) { + min_num = b; + } + for (i = 1; i <= min_num; i++) { + if (a % i == 0 && b % i == 0) { + gcd = i; + } + } + return gcd; } /** * Compute the greatest common divisor of two integer values, standard or bigint - * + * * @param left the left integer value * @param right the right integer value * @return the gcd value @@ -1485,7 +1487,7 @@ static Value intGcd(Value left, Value right) { /** * Negate an integer value in place. - * + * * @param v the integer value to negate */ static void intNegInPlace(Value *v) { @@ -1498,7 +1500,7 @@ static void intNegInPlace(Value *v) { /** * Negate an integer value, returning a new value. - * + * * @param v the integer value to negate * @return the negated value */ @@ -1518,7 +1520,7 @@ static Value intNeg(Value v) { /** * Negate a number value, returning a new value. - * + * * @param v the number value to negate * @return the negated value */ @@ -1537,7 +1539,7 @@ static Value numNeg(Value v) { /** * Compare two bigint values - * + * * @param left the left bigint value * @param right the right bigint value * @return comparison result @@ -1554,7 +1556,7 @@ static inline Cmp bigCmp(Value left, Value right) { /** * Compare two standard integer values - * + * * @param left the left standard integer value * @param right the right standard integer value * @return comparison result @@ -1562,9 +1564,9 @@ static inline Cmp bigCmp(Value left, Value right) { static inline Cmp stdCmp(Value left, Value right) { ASSERT_STDINT(left); ASSERT_STDINT(right); - return left.val.stdint < right.val.stdint ? CMP_LT : - left.val.stdint == right.val.stdint ? CMP_EQ : CMP_GT; - + return left.val.stdint < right.val.stdint ? CMP_LT + : left.val.stdint == right.val.stdint ? CMP_EQ + : CMP_GT; } //////////////////////// @@ -1573,7 +1575,7 @@ static inline Cmp stdCmp(Value left, Value right) { /** * Compare two rational values - * + * * @param left the left rational value * @param right the right rational value * @return comparison result @@ -1596,15 +1598,17 @@ static Cmp ratCmp(Value left, Value right) { /** * Apply a binary operation to two values, promoting to rational as needed. - * + * * @param left the left value * @param right the right value * @param op the parameterized binary operation to apply - * @param intOp the integer binary operation to apply if both values are integers + * @param intOp the integer binary operation to apply if both values are + * integers * @param simplify whether to attempt to simplify to integer if possible * @return the result value */ -static Value ratOp(Value left, Value right, ParameterizedBinOp op, IntegerBinOp intOp, bool simplify) { +static Value ratOp(Value left, Value right, ParameterizedBinOp op, + IntegerBinOp intOp, bool simplify) { ENTER(ratOp); IFDEBUG(ppNumber(left)); IFDEBUG(ppNumber(right)); @@ -1666,7 +1670,7 @@ static Value ratOp(Value left, Value right, ParameterizedBinOp op, IntegerBinOp * Simplify a rational value by dividing numerator and denominator * by their greatest common divisor. * Ensures the denominator is positive. - * + * * @param numerator the numerator value * @param denominator the denominator value * @return the simplified rational value @@ -1701,11 +1705,13 @@ static Value ratSimplify(Value numerator, Value denominator) { } /** - * Applies an addition, subtraction, or modulus operation to two rational values, - * by cross-multiplying the numerators and denominators: - * \f( \frac{a}{b} \text{ op } \frac{c}{d} = \frac{(ad) \text{ op } (bc)}{bd} \f) - * - * @param base_op the integer operation to apply to the cross-multiplied numerators + * Applies an addition, subtraction, or modulus operation to two rational + * values, by cross-multiplying the numerators and denominators: + * \f( \frac{a}{b} \text{ op } \frac{c}{d} = \frac{(ad) \text{ op } (bc)}{bd} + * \f) + * + * @param base_op the integer operation to apply to the cross-multiplied + * numerators * @param left the left rational value * @param right the right rational value * @return the result value @@ -1716,17 +1722,14 @@ static Value ratAddSubOrMod(IntegerBinOp base_op, Value left, Value right) { IFDEBUG(ppNumber(right)); ASSERT_RATIONAL(left); ASSERT_RATIONAL(right); - Value a1b2 = - intMul(numeratorPart(left), denominatorPart(right)); + Value a1b2 = intMul(numeratorPart(left), denominatorPart(right)); int save = protectValue(a1b2); - Value a2b1 = - intMul(denominatorPart(left), numeratorPart(right)); + Value a2b1 = intMul(denominatorPart(left), numeratorPart(right)); protectValue(a2b1); Value numerator = base_op(a1b2, a2b1); protectValue(numerator); - Value denominator = - intMul(left.val.vec->entries[DENOMINATOR], - right.val.vec->entries[DENOMINATOR]); + Value denominator = intMul(left.val.vec->entries[DENOMINATOR], + right.val.vec->entries[DENOMINATOR]); protectValue(denominator); Value res = ratSimplify(numerator, denominator); protectValue(res); @@ -1740,8 +1743,9 @@ static Value ratAddSubOrMod(IntegerBinOp base_op, Value left, Value right) { * Applies a multiplication operation on two rational values, * by multiplying the numerators and denominators: * \f( \frac{a}{b} \times \frac{c}{d} = \frac{ac}{bd} \f) - * - * @param base_op the integer operation to apply to the numerators and denominators + * + * @param base_op the integer operation to apply to the numerators and + * denominators * @param left the left rational value * @param right the right rational value * @return the result value @@ -1752,11 +1756,9 @@ static Value rat_ac_bd(IntegerBinOp base_op, Value left, Value right) { IFDEBUG(ppNumber(right)); ASSERT_RATIONAL(left); ASSERT_RATIONAL(right); - Value numerator = - base_op(numeratorPart(left), numeratorPart(right)); + Value numerator = base_op(numeratorPart(left), numeratorPart(right)); int save = protectValue(numerator); - Value denominator = - base_op(denominatorPart(left), denominatorPart(right)); + Value denominator = base_op(denominatorPart(left), denominatorPart(right)); protectValue(denominator); Value res = ratSimplify(numerator, denominator); protectValue(res); @@ -1770,9 +1772,11 @@ static Value rat_ac_bd(IntegerBinOp base_op, Value left, Value right) { * Applies a division operation on two rational values, * by flipping the numerator and denominator of the right operand and * multiplying: - * \f( \frac{a}{b} \div \frac{c}{d} = \frac{a}{b} \times \frac{d}{c} = \frac{ ad }{ bc} \f) - * - * @param base_op the integer operation to apply to the cross-multiplied numerators + * \f( \frac{a}{b} \div \frac{c}{d} = \frac{a}{b} \times \frac{d}{c} = \frac{ ad + * }{ bc} \f) + * + * @param base_op the integer operation to apply to the cross-multiplied + * numerators * @param left the left rational value * @param right the right rational value * @return the result value @@ -1795,7 +1799,7 @@ static Value ratDiv3(IntegerBinOp base_op, Value left, Value right) { /** * Divide two rational values - * + * * @param left the left rational value * @param right the right rational value * @return the result value @@ -1813,7 +1817,7 @@ static Value ratDiv(Value left, Value right) { /** * Raise a rational value to an integer or rational power. - * + * * @param left the base rational value * @param right the exponent integer or rational value * @return the result value @@ -1841,7 +1845,7 @@ static Value ratPow(Value left, Value right) { /** * Modulus of two rational values: * \f( \frac{a}{b} \mod \frac{c}{d} = \frac{(ad) \mod (bc)}{bd} \f) - * + * * @param left the left rational value * @param right the right rational value * @return the result value @@ -1863,7 +1867,7 @@ static Value ratMod(Value left, Value right) { /** * Multiplication of two rational values: * \f( \frac{a}{b} \times \frac{c}{d} = \frac{ac}{bd} \f) - * + * * @param left the left rational value * @param right the right rational value * @return the result value @@ -1882,7 +1886,7 @@ static Value ratMul(Value left, Value right) { /** * Division of two rational or integer values - * + * * @param left the left rational value * @param right the right rational value * @return the result rational value @@ -1891,7 +1895,8 @@ static Value intDiv(Value left, Value right) { ENTER(intDiv); IFDEBUG(ppNumber(left)); IFDEBUG(ppNumber(right)); - Value res = ratOp(left, right, ratDiv3, intMul, false); // N.B. intMul not basicIntDiv + Value res = ratOp(left, right, ratDiv3, intMul, + false); // N.B. intMul not basicIntDiv int save = protectValue(res); LEAVE(intDiv); IFDEBUG(ppNumber(res)); @@ -1902,7 +1907,7 @@ static Value intDiv(Value left, Value right) { /** * Subtraction of two rational values: * \f( \frac{a}{b} - \frac{c}{d} = \frac{(ad) - (bc)}{bd} \f) - * + * * @param left the left rational value * @param right the right rational value * @return the result value @@ -1922,7 +1927,7 @@ static Value ratSub(Value left, Value right) { /** * Addition of two rational values: * \f( \frac{a}{b} + \frac{c}{d} = \frac{(ad) + (bc)}{bd} \f) - * + * * @param left the left rational value * @param right the right rational value * @return the result value @@ -1946,8 +1951,9 @@ static Value ratAdd(Value left, Value right) { static inline Cmp irrCmp(Value left, Value right) { ASSERT_IRRATIONAL(left); ASSERT_IRRATIONAL(right); - return left.val.irrational < right.val.irrational ? CMP_LT : - left.val.irrational == right.val.irrational ? CMP_EQ : CMP_GT; + return left.val.irrational < right.val.irrational ? CMP_LT + : left.val.irrational == right.val.irrational ? CMP_EQ + : CMP_GT; } static Value irrMod(Value left, Value right) { @@ -1983,7 +1989,7 @@ static Value irrAdd(Value left, Value right) { /** * Raise an irrational number to a complex power. * \f( c^(a + bi) = c^a [\cos(b \ln c) + i \sin(b \ln c)] \f) - * + * * @param c the base irrational value * @param right the exponent complex value * @return the result value @@ -2271,7 +2277,8 @@ static Value comPowCom(Value base, Value exponent) { // tie breaker for unequal complex numbers // *NOT* a general purpose comparison -static Cmp magCmp(Value left_real, Value left_imag, Value right_real, Value right_imag) { +static Cmp magCmp(Value left_real, Value left_imag, Value right_real, + Value right_imag) { Value left_c = nadd(left_real, left_imag); int save = protectValue(left_c); Value right_c = nadd(right_real, right_imag); @@ -2279,21 +2286,20 @@ static Cmp magCmp(Value left_real, Value left_imag, Value right_real, Value righ Cmp res = CMP_EQ; Cmp res1 = ncmp(left_c, right_c); switch (res1) { - case CMP_LT: - UNPROTECT(save); - res = CMP_LT; - break; - case CMP_EQ: { - Cmp res2 = ncmp(left_real, right_real); - UNPROTECT(save); - // ensures that comparison is order-independant - res = res2 == CMP_LT ? CMP_LT : CMP_GT; - } + case CMP_LT: + UNPROTECT(save); + res = CMP_LT; + break; + case CMP_EQ: { + Cmp res2 = ncmp(left_real, right_real); + UNPROTECT(save); + // ensures that comparison is order-independant + res = res2 == CMP_LT ? CMP_LT : CMP_GT; + } break; + case CMP_GT: + UNPROTECT(save); + res = CMP_GT; break; - case CMP_GT: - UNPROTECT(save); - res = CMP_GT; - break; } return res; } @@ -2308,41 +2314,41 @@ static Cmp comCmp(Value left, Value right) { Cmp imag_cmp = ncmp(left_imag, right_imag); Cmp res = CMP_EQ; switch (real_cmp) { + case CMP_LT: + switch (imag_cmp) { case CMP_LT: - switch (imag_cmp) { - case CMP_LT: - case CMP_EQ: - res = CMP_LT; - break; - case CMP_GT: - res = magCmp(left_real, left_imag, right_real, right_imag); - break; - } + case CMP_EQ: + res = CMP_LT; + break; + case CMP_GT: + res = magCmp(left_real, left_imag, right_real, right_imag); + break; + } + break; + case CMP_EQ: + switch (imag_cmp) { + case CMP_LT: + res = CMP_LT; break; case CMP_EQ: - switch (imag_cmp) { - case CMP_LT: - res = CMP_LT; - break; - case CMP_EQ: - res = CMP_EQ; - break; - case CMP_GT: - res = CMP_GT; - break; - } + res = CMP_EQ; break; case CMP_GT: - switch (imag_cmp) { - case CMP_LT: - res = magCmp(left_real, left_imag, right_real, right_imag); - break; - case CMP_EQ: - case CMP_GT: - res = CMP_GT; - break; - } + res = CMP_GT; break; + } + break; + case CMP_GT: + switch (imag_cmp) { + case CMP_LT: + res = magCmp(left_real, left_imag, right_real, right_imag); + break; + case CMP_EQ: + case CMP_GT: + res = CMP_GT; + break; + } + break; } return res; } @@ -2352,40 +2358,41 @@ static Cmp comCmp(Value left, Value right) { //////////////////////// #ifdef SAFETY_CHECKS -# define CHECK_INITIALIZED() do { \ - if (!arithmetic_initialized) { \ - cant_happen("arithmetic not initialized yet"); \ - } \ -} while(0) +#define CHECK_INITIALIZED() \ + do { \ + if (!arithmetic_initialized) { \ + cant_happen("arithmetic not initialized yet"); \ + } \ + } while (0) #else -# define CHECK_INITIALIZED() +#define CHECK_INITIALIZED() #endif - -static Value dispatch(Value left, Value right, ValOp intOp, ValOp bigOp, ValOp ratOp, ValOp irrOp, ValOp comOp) { +static Value dispatch(Value left, Value right, ValOp intOp, ValOp bigOp, + ValOp ratOp, ValOp irrOp, ValOp comOp) { ENTER(dispatch); IFDEBUG(ppNumber(left)); IFDEBUG(ppNumber(right)); int save = PROTECT(NULL); Value res; switch (coerce(&left, &right, &save)) { - case VALUE_TYPE_RATIONAL: - res = ratOp(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - res = irrOp(left, right); - break; - case VALUE_TYPE_STDINT: - res = intOp(left, right); - break; - case VALUE_TYPE_BIGINT: - res = bigOp(left, right); - break; - case VALUE_TYPE_COMPLEX: - res = comOp(left, right); - break; - default: - cant_happen("unexpected result from coerce"); + case VALUE_TYPE_RATIONAL: + res = ratOp(left, right); + break; + case VALUE_TYPE_IRRATIONAL: + res = irrOp(left, right); + break; + case VALUE_TYPE_STDINT: + res = intOp(left, right); + break; + case VALUE_TYPE_BIGINT: + res = bigOp(left, right); + break; + case VALUE_TYPE_COMPLEX: + res = comOp(left, right); + break; + default: + cant_happen("unexpected result from coerce"); } protectValue(res); LEAVE(dispatch); @@ -2454,308 +2461,311 @@ Value npow(Value left, Value right) { IFDEBUG(ppNumber(right)); Value res; int save = PROTECT(NULL); - switch(left.type) { + switch (left.type) { + case VALUE_TYPE_RATIONAL: + switch (right.type) { case VALUE_TYPE_RATIONAL: - switch(right.type) { - case VALUE_TYPE_RATIONAL: - res = realPowRat(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - left = rational_to_irrational(left); - res = irratSimplify(pow(left.val.irrational, right.val.irrational)); - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = ratPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: { - left = rational_to_irrational(left); - res = irrPowCom(left, right); - } - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } + res = realPowRat(left, right); break; case VALUE_TYPE_IRRATIONAL: - switch(right.type) { - case VALUE_TYPE_RATIONAL: - res = realPowRat(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - res = irratSimplify(pow(left.val.irrational, right.val.irrational)); - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - right = int_to_irrational(right); - res = irratSimplify(pow(left.val.irrational, right.val.irrational)); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - res = irrPowCom(left, right); - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } + left = rational_to_irrational(left); + res = irratSimplify(pow(left.val.irrational, right.val.irrational)); break; case VALUE_TYPE_BIGINT: - switch(right.type) { - case VALUE_TYPE_RATIONAL: - res = realPowRat(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - left = int_to_irrational(left); - res = irratSimplify(pow(left.val.irrational, right.val.irrational)); - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = intPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: { - left = int_to_irrational(left); - res = irrPowCom(left, right); - } - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } - break; case VALUE_TYPE_STDINT: - switch(right.type) { - case VALUE_TYPE_IRRATIONAL: - left = int_to_irrational(left); - res = irratSimplify(pow(left.val.irrational, right.val.irrational)); - break; - case VALUE_TYPE_RATIONAL: - res = realPowRat(left, right); - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = intPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: { - left = int_to_irrational(left); - res = irrPowCom(left, right); - } - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } + res = ratPow(left, right); break; case VALUE_TYPE_BIGINT_IMAG: - switch (right.type) { - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL:{ - Value real = imag_to_real(left); - res = npow(real, right); - protectValue(res); - res = real_to_imag(res); - } - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = comPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - res = comPowCom(left, right); - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } - break; case VALUE_TYPE_STDINT_IMAG: - switch (right.type) { - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL:{ - Value real = imag_to_real(left); - res = npow(real, right); - protectValue(res); - res = real_to_imag(res); - } - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = comPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - res = comPowCom(left, right); - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } - break; case VALUE_TYPE_RATIONAL_IMAG: - switch (right.type) { - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL:{ - Value real = imag_to_real(left); - res = npow(real, right); - protectValue(res); - res = real_to_imag(res); - } - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = comPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - res = comPowCom(left, right); - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } - break; case VALUE_TYPE_IRRATIONAL_IMAG: - switch (right.type) { - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL:{ - Value real = imag_to_real(left); - res = npow(real, right); - protectValue(res); - res = real_to_imag(res); - } - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = comPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - res = comPowCom(left, right); - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } + case VALUE_TYPE_COMPLEX: { + left = rational_to_irrational(left); + res = irrPowCom(left, right); + } break; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_IRRATIONAL: + switch (right.type) { + case VALUE_TYPE_RATIONAL: + res = realPowRat(left, right); break; + case VALUE_TYPE_IRRATIONAL: + res = irratSimplify(pow(left.val.irrational, right.val.irrational)); + break; + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + right = int_to_irrational(right); + res = irratSimplify(pow(left.val.irrational, right.val.irrational)); + break; + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: case VALUE_TYPE_COMPLEX: - switch (right.type) { - case VALUE_TYPE_RATIONAL: - res = comPowRat(left, right); - break; - case VALUE_TYPE_IRRATIONAL: - right = real_to_complex(right); - protectValue(right); - res = comPowCom(left, right); - break; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - res = comPow(left, right); - break; - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - res = comPowCom(left, right); - break; - default: - cant_happen("unrecognised right number type %s", valueTypeName(right.type)); - } + res = irrPowCom(left, right); break; default: - cant_happen("unrecognised left number type %s", valueTypeName(left.type)); - } - protectValue(res); - LEAVE(npow); - IFDEBUG(ppNumber(res)); - UNPROTECT(save); - return res; -} - -Cmp ncmp(Value left, Value right) { - ENTER(ncmp); - CHECK_INITIALIZED(); - Cmp res = CMP_EQ; - int save = PROTECT(NULL); - switch (coerce(&left, &right, &save)) { + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_BIGINT: + switch (right.type) { case VALUE_TYPE_RATIONAL: - res = ratCmp(left, right); + res = realPowRat(left, right); break; case VALUE_TYPE_IRRATIONAL: - res = irrCmp(left, right); + left = int_to_irrational(left); + res = irratSimplify(pow(left.val.irrational, right.val.irrational)); break; + case VALUE_TYPE_BIGINT: case VALUE_TYPE_STDINT: - res = stdCmp(left, right); + res = intPow(left, right); + break; + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + case VALUE_TYPE_COMPLEX: { + left = int_to_irrational(left); + res = irrPowCom(left, right); + } break; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_STDINT: + switch (right.type) { + case VALUE_TYPE_IRRATIONAL: + left = int_to_irrational(left); + res = irratSimplify(pow(left.val.irrational, right.val.irrational)); + break; + case VALUE_TYPE_RATIONAL: + res = realPowRat(left, right); break; case VALUE_TYPE_BIGINT: - res = bigCmp(left, right); + case VALUE_TYPE_STDINT: + res = intPow(left, right); break; + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + case VALUE_TYPE_COMPLEX: { + left = int_to_irrational(left); + res = irrPowCom(left, right); + } break; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_BIGINT_IMAG: + switch (right.type) { + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: { + Value real = imag_to_real(left); + res = npow(real, right); + protectValue(res); + res = real_to_imag(res); + } break; + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + res = comPow(left, right); + break; + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: case VALUE_TYPE_COMPLEX: - res = comCmp(left, right); + res = comPowCom(left, right); break; default: - cant_happen("unexpected result from coerce"); - } - LEAVE(ncmp); - UNPROTECT(save); - return res; -} - -Value real_part(Value v) { - switch(v.type) { + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_STDINT_IMAG: + switch (right.type) { case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_IRRATIONAL: { + Value real = imag_to_real(left); + res = npow(real, right); + protectValue(res); + res = real_to_imag(res); + } break; case VALUE_TYPE_BIGINT: case VALUE_TYPE_STDINT: - return v; + res = comPow(left, right); + break; + case VALUE_TYPE_BIGINT_IMAG: case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + case VALUE_TYPE_COMPLEX: + res = comPowCom(left, right); + break; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_RATIONAL_IMAG: + switch (right.type) { + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: { + Value real = imag_to_real(left); + res = npow(real, right); + protectValue(res); + res = real_to_imag(res); + } break; + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + res = comPow(left, right); + break; case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: case VALUE_TYPE_RATIONAL_IMAG: case VALUE_TYPE_IRRATIONAL_IMAG: - return value_Stdint(0); case VALUE_TYPE_COMPLEX: - return realPart(v); + res = comPowCom(left, right); + break; default: - cant_happen("unrecognised number type %s", valueTypeName(v.type)); - } -} - -Value imag_part(Value v) { - switch(v.type) { + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_IRRATIONAL_IMAG: + switch (right.type) { case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_IRRATIONAL: { + Value real = imag_to_real(left); + res = npow(real, right); + protectValue(res); + res = real_to_imag(res); + } break; case VALUE_TYPE_BIGINT: case VALUE_TYPE_STDINT: - return value_Stdint_imag(0); + res = comPow(left, right); + break; + case VALUE_TYPE_BIGINT_IMAG: case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + case VALUE_TYPE_COMPLEX: + res = comPowCom(left, right); + break; + default: + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + case VALUE_TYPE_COMPLEX: + switch (right.type) { + case VALUE_TYPE_RATIONAL: + res = comPowRat(left, right); + break; + case VALUE_TYPE_IRRATIONAL: + right = real_to_complex(right); + protectValue(right); + res = comPowCom(left, right); + break; + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + res = comPow(left, right); + break; case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: case VALUE_TYPE_RATIONAL_IMAG: case VALUE_TYPE_IRRATIONAL_IMAG: - return v; case VALUE_TYPE_COMPLEX: - return imagPart(v); + res = comPowCom(left, right); + break; default: - cant_happen("unrecognised number type %s", valueTypeName(v.type)); + cant_happen("unrecognised right number type %s", + valueTypeName(right.type)); + } + break; + default: + cant_happen("unrecognised left number type %s", + valueTypeName(left.type)); + } + protectValue(res); + LEAVE(npow); + IFDEBUG(ppNumber(res)); + UNPROTECT(save); + return res; +} + +Cmp ncmp(Value left, Value right) { + ENTER(ncmp); + CHECK_INITIALIZED(); + Cmp res = CMP_EQ; + int save = PROTECT(NULL); + switch (coerce(&left, &right, &save)) { + case VALUE_TYPE_RATIONAL: + res = ratCmp(left, right); + break; + case VALUE_TYPE_IRRATIONAL: + res = irrCmp(left, right); + break; + case VALUE_TYPE_STDINT: + res = stdCmp(left, right); + break; + case VALUE_TYPE_BIGINT: + res = bigCmp(left, right); + break; + case VALUE_TYPE_COMPLEX: + res = comCmp(left, right); + break; + default: + cant_happen("unexpected result from coerce"); + } + LEAVE(ncmp); + UNPROTECT(save); + return res; +} + +Value real_part(Value v) { + switch (v.type) { + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + return v; + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + return value_Stdint(0); + case VALUE_TYPE_COMPLEX: + return realPart(v); + default: + cant_happen("unrecognised number type %s", valueTypeName(v.type)); + } +} + +Value imag_part(Value v) { + switch (v.type) { + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + return value_Stdint_imag(0); + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + return v; + case VALUE_TYPE_COMPLEX: + return imagPart(v); + default: + cant_happen("unrecognised number type %s", valueTypeName(v.type)); } } @@ -2797,7 +2807,8 @@ Value nrand(Value prev) { CHECK_INITIALIZED(); ASSERT_IRRATIONAL(prev); Double seed = fmod(prev.val.irrational, 1.0); - if (seed < 0) seed = -seed; + if (seed < 0) + seed = -seed; seed *= UINT_MAX; seed = fmod(seed * 1103515245.0 + 12345.0, (Double)UINT_MAX); seed /= UINT_MAX; diff --git a/src/bytecode.c b/src/bytecode.c index 205612b2..5d4fa689 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -103,14 +103,19 @@ static void addByte(ByteCodeArray *b, int code) { b->entries[b->size++] = code; } -static void writeWordAt(Control loc, ByteCodeArray *b, Word word) { - DEBUG("%04x writeWord %04x", loc, word); - memcpy(&b->entries[loc], &word, sizeof(Word)); +static void writeWordAt(Control loc, ByteCodeArray *b, Word w) { + DEBUG("%04x writeWord %04x", loc, w); + memcpy(&b->entries[loc], &w, sizeof(Word)); } -static void writeIntegerAt(Control loc, ByteCodeArray *b, Integer word) { - DEBUG("%04x writeInt %d", loc, word); - memcpy(&b->entries[loc], &word, sizeof(Integer)); +static void writeShortAt(Control loc, ByteCodeArray *b, Short s) { + DEBUG("%04x writeShort %04x", loc, s); + memcpy(&b->entries[loc], &s, sizeof(Short)); +} + +static void writeIntegerAt(Control loc, ByteCodeArray *b, Integer i) { + DEBUG("%04x writeInt %d", loc, i); + memcpy(&b->entries[loc], &i, sizeof(Integer)); } static void writeCharacterAt(Control loc, ByteCodeArray *b, Character c) { @@ -134,6 +139,15 @@ static void addWord(ByteCodeArray *b, Word w) { b->size += sizeof(Word); } +__attribute__((unused)) static void addShort(ByteCodeArray *b, int w) { + if (w > 65535) { + cant_happen("maximim byte size exceeded"); + } + reserve(b, sizeof(Short)); + writeShortAt(b->size, b, w); + b->size += sizeof(Short); +} + static Control reserveWord(ByteCodeArray *b) { Control address = b->size; addWord(b, 0); @@ -200,12 +214,21 @@ void writeAexpAnnotatedVar(AexpAnnotatedVar *x, ByteCodeArray *b, switch (x->type) { case AEXPANNOTATEDVARTYPE_TYPE_ENV: addByte(b, BYTECODES_TYPE_VAR); +#ifdef SIXTEEN_BIT_ENVIRONMENT + addShort(b, x->frame); + addShort(b, x->offset); +#else addByte(b, x->frame); addByte(b, x->offset); +#endif break; case AEXPANNOTATEDVARTYPE_TYPE_STACK: addByte(b, BYTECODES_TYPE_LVAR); +#ifdef SIXTEEN_BIT_ENVIRONMENT + addShort(b, x->offset); +#else addByte(b, x->offset); +#endif break; default: cant_happen("unrecognised annotated var type"); diff --git a/src/bytecode.h b/src/bytecode.h index ba33e3bd..a7f4275f 100644 --- a/src/bytecode.h +++ b/src/bytecode.h @@ -1,5 +1,5 @@ #ifndef cekf_bytecode_h -# define cekf_bytecode_h +#define cekf_bytecode_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,13 +18,15 @@ * along with this program. If not, see . */ -# include "anf.h" -# include "memory.h" -# include "types.h" -# include "cekfs.h" +#include "anf.h" +#include "cekfs.h" +#include "memory.h" +#include "types.h" // MUST remember to increment this if bytecodes change -# define CEKF_BYTECODE_VERSION 5 +#define CEKF_BYTECODE_VERSION 5 + +#define SIXTEEN_BIT_ENVIRONMENT enum ReadByteCodeStatus { BYTECODES_OK, @@ -38,14 +40,16 @@ char *charRep(Character c); void resetByteCodeArray(ByteCodeArray *b); void writeAexpLam(AexpLam *x, ByteCodeArray *b, LocationArray *L); -void writeAexpAnnotatedVar(AexpAnnotatedVar *x, ByteCodeArray *b, LocationArray *L); +void writeAexpAnnotatedVar(AexpAnnotatedVar *x, ByteCodeArray *b, + LocationArray *L); void writeAexpPrimApp(AexpPrimApp *x, ByteCodeArray *b, LocationArray *L); void writeAexpList(AexpList *x, ByteCodeArray *b, LocationArray *L); void writeCexpApply(CexpApply *x, ByteCodeArray *b, LocationArray *L); void writeCexpIf(CexpIf *x, ByteCodeArray *b, LocationArray *L); void writeCexpMatch(CexpMatch *x, ByteCodeArray *b, LocationArray *L); void writeCexpLetRec(CexpLetRec *x, ByteCodeArray *b, LocationArray *L); -void writeLetRecBindings(AnfLetRecBindings *x, ByteCodeArray *b, LocationArray *L); +void writeLetRecBindings(AnfLetRecBindings *x, ByteCodeArray *b, + LocationArray *L); void writeCexpAmb(CexpAmb *x, ByteCodeArray *b, LocationArray *L); void writeCexpCut(CexpCut *x, ByteCodeArray *b, LocationArray *L); void writeAnfExpLet(AnfExpLet *x, ByteCodeArray *b, LocationArray *L); @@ -80,6 +84,17 @@ static inline Word readWord(ByteCodeArray *b, Control *i) { return a; } +static inline void _readShort(ByteCodeArray *b, Control *i, Short *s) { + memcpy(s, &b->entries[*i], sizeof(Short)); + (*i) += sizeof(Short); +} + +static inline Short readShort(ByteCodeArray *b, Control *i) { + Short s; + _readShort(b, i, &s); + return s; +} + static inline void _readInteger(ByteCodeArray *b, Control *i, Integer *a) { memcpy(a, &b->entries[*i], sizeof(Integer)); (*i) += sizeof(Integer); diff --git a/src/debug.c b/src/debug.c index c929255e..c901da3d 100644 --- a/src/debug.c +++ b/src/debug.c @@ -21,10 +21,10 @@ #include #include +#include "builtins_debug.h" #include "common.h" #include "debug.h" #include "hash.h" -#include "builtins_debug.h" static void loc(size_t ii, size_t *li, LocationArray *l) { static Location prev; @@ -34,7 +34,8 @@ static void loc(size_t ii, size_t *li, LocationArray *l) { } if (*li < l->size && ii == l->entries[*li]->loc) { Location *found = l->entries[*li]; - if (prev.lineNo != found->lineNo || prev.fileName != found->fileName) { + if (prev.lineNo != found->lineNo || + prev.fileName != found->fileName) { eprintf(" # %s %d", found->fileName, found->lineNo); prev = *found; } @@ -51,320 +52,280 @@ void dumpByteCode(ByteCodeArray *b, LocationArray *l) { eprintf("%04lx ", ii); int thisByte; switch (thisByte = readByte(b, &i)) { - case BYTECODES_TYPE_NONE:{ - eprintf("NONE"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_LAM:{ - int nArgs = readByte(b, &i); - int letRecOffset = readByte(b, &i); - int offset = readOffset(b, &i); - eprintf("LAM [%d][%d][%04x]", nArgs, letRecOffset, - offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_VAR:{ - int frame = readByte(b, &i); - int offset = readByte(b, &i); - eprintf("VAR [%d:%d]", frame, offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_LVAR:{ - int offset = readByte(b, &i); - eprintf("LVAR [%d]", offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_ADD:{ - eprintf("ADD"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_SUB:{ - eprintf("SUB"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_MUL:{ - eprintf("MUL"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_DIV:{ - eprintf("DIV"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_POW:{ - eprintf("POW"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_MOD:{ - eprintf("MOD"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_EQ:{ - eprintf("EQ"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_NE:{ - eprintf("NE"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_GT:{ - eprintf("GT"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_LT:{ - eprintf("LT"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_GE:{ - eprintf("GE"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_LE:{ - eprintf("LE"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_CMP:{ - eprintf("CMP"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_MAKEVEC:{ - int size = readByte(b, &i); - eprintf("MAKEVEC [%d]", size); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PRIM_VEC:{ - eprintf("VEC"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_APPLY:{ - int nArgs = readByte(b, &i); - eprintf("APPLY [%d]", nArgs); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_IF:{ - int offset = readOffset(b, &i); - eprintf("IF [%04x]", offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_MATCH:{ - int count = readByte(b, &i); - eprintf("MATCH [%d]", count); - while (count > 0) { - int offset = readOffset(b, &i); - eprintf("[%04x]", offset); - count--; - } - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_CHARCOND:{ - int count = readWord(b, &i); - eprintf("CHARCOND [%d]", count); - while (count > 0) { - int val = readInteger(b, &i); - int offset = readOffset(b, &i); - eprintf(" %d:[%04x]", val, offset); - count--; - } - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_INTCOND:{ - int count = readWord(b, &i); - eprintf("INTCOND [%d]", count); - while (count > 0) { - int type = readByte(b, &i); - switch (type) { - case BYTECODES_TYPE_BIGINT: { - bigint bi = readBigint(b, &i); - eprintf(" [bigint]"); - bigint_fprint(errout, &bi); - bigint_free(&bi); - } - break; - case BYTECODES_TYPE_STDINT: { - int li = readInteger(b, &i); - eprintf(" [int]%d", li); - } - break; - default: - cant_happen("expected INT or BIGINT in BYTECODES_TYPE_INTCOND cases"); - } - int offset = readOffset(b, &i); - eprintf(":[%04x]", offset); - count--; - } - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_LETREC:{ - int size = readByte(b, &i); - eprintf("LETREC [%d]", size); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_AMB:{ - int offset = readOffset(b, &i); - eprintf("AMB [%04x]", offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_CUT:{ - eprintf("CUT"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_BACK:{ - eprintf("BACK"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_LET:{ - int offset = readOffset(b, &i); - eprintf("LET [%04x]", offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_JMP:{ - int offset = readOffset(b, &i); - eprintf("JMP [%04x]", offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_PUSHN:{ - int size = readByte(b, &i); - eprintf("PUSHN [%d]", size); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_CALLCC:{ - eprintf("CALLCC"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_STDINT_IMAG:{ - int val = readInteger(b, &i); - eprintf("STDINT_IMAG [%d]", val); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_STDINT:{ - int val = readInteger(b, &i); - eprintf("STDINT [%d]", val); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_BIGINT:{ - eprintf("BIGINT ["); - bigint bi = readBigint(b, &i); - bigint_fprint(errout, &bi); - eprintf("]"); - bigint_free(&bi); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_BIGINT_IMAG:{ - eprintf("BIGINT_IMAG ["); + case BYTECODES_TYPE_NONE: { + eprintf("NONE"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_LAM: { + int nArgs = readByte(b, &i); + int letRecOffset = readByte(b, &i); + int offset = readOffset(b, &i); + eprintf("LAM [%d][%d][%04x]", nArgs, letRecOffset, offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_VAR: { + +#ifdef SIXTEEN_BIT_ENVIRONMENT + int frame = readShort(b, &i); + int offset = readShort(b, &i); +#else + int frame = readByte(b, &i); + int offset = readByte(b, &i); +#endif + eprintf("VAR [%d:%d]", frame, offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_LVAR: { +#ifdef SIXTEEN_BIT_ENVIRONMENT + int offset = readShort(b, &i); +#else + int offset = readByte(b, &i); +#endif + eprintf("LVAR [%d]", offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_ADD: { + eprintf("ADD"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_SUB: { + eprintf("SUB"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_MUL: { + eprintf("MUL"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_DIV: { + eprintf("DIV"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_POW: { + eprintf("POW"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_MOD: { + eprintf("MOD"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_EQ: { + eprintf("EQ"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_NE: { + eprintf("NE"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_GT: { + eprintf("GT"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_LT: { + eprintf("LT"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_GE: { + eprintf("GE"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_LE: { + eprintf("LE"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_CMP: { + eprintf("CMP"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_MAKEVEC: { + int size = readByte(b, &i); + eprintf("MAKEVEC [%d]", size); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PRIM_VEC: { + eprintf("VEC"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_APPLY: { + int nArgs = readByte(b, &i); + eprintf("APPLY [%d]", nArgs); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_IF: { + int offset = readOffset(b, &i); + eprintf("IF [%04x]", offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_MATCH: { + int count = readByte(b, &i); + eprintf("MATCH [%d]", count); + while (count > 0) { + int offset = readOffset(b, &i); + eprintf("[%04x]", offset); + count--; + } + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_CHARCOND: { + int count = readWord(b, &i); + eprintf("CHARCOND [%d]", count); + while (count > 0) { + int val = readInteger(b, &i); + int offset = readOffset(b, &i); + eprintf(" %d:[%04x]", val, offset); + count--; + } + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_INTCOND: { + int count = readWord(b, &i); + eprintf("INTCOND [%d]", count); + while (count > 0) { + int type = readByte(b, &i); + switch (type) { + case BYTECODES_TYPE_BIGINT: { bigint bi = readBigint(b, &i); + eprintf(" [bigint]"); bigint_fprint(errout, &bi); - eprintf("]"); - loc(ii, &li, l); bigint_free(&bi); - } - break; - case BYTECODES_TYPE_IRRATIONAL:{ - Double f = readDouble(b, &i); - eprintf("IRRATIONAL [%f]", f); - loc(ii, &li, l); + } break; + case BYTECODES_TYPE_STDINT: { + int li = readInteger(b, &i); + eprintf(" [int]%d", li); + } break; + default: + cant_happen("expected INT or BIGINT in " + "BYTECODES_TYPE_INTCOND cases"); + } + int offset = readOffset(b, &i); + eprintf(":[%04x]", offset); + count--; } - break; - case BYTECODES_TYPE_IRRATIONAL_IMAG:{ - Double f = readDouble(b, &i); - eprintf("IRRATIONAL_IMAG [%f]", f); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_CHAR:{ - Character c = readCharacter(b, &i); - eprintf("CHAR [%s]", charRep(c)); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_RETURN:{ - eprintf("RETURN"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_DONE:{ - eprintf("DONE"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_ERROR:{ - eprintf("ERROR"); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_NS_START:{ - int count = readWord(b, &i); - eprintf("NS_START [%d]", count); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_NS_END:{ - int numLambdas = readWord(b, &i); - int stackOffset = readWord(b, &i); - eprintf("NS_END [%d][%d]", numLambdas, stackOffset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_NS_FINISH:{ - int count = readWord(b, &i); - eprintf("NS_FINISH [%d]", count); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_NS_PUSHSTACK:{ - int offset = readWord(b, &i); - eprintf("NS_PUSHSTACK [%d]", offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_NS_PUSHENV:{ - int frame = readWord(b, &i); - int offset = readWord(b, &i); - eprintf("NS_PUSHENV [%d][%d]", frame, offset); - loc(ii, &li, l); - } - break; - case BYTECODES_TYPE_NS_POP:{ - eprintf("NS_POP"); - loc(ii, &li, l); - } - break; - default: - cant_happen("unrecognised bytecode %s in dumpByteCode", - byteCodesName(thisByte)); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_LETREC: { + int size = readByte(b, &i); + eprintf("LETREC [%d]", size); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_AMB: { + int offset = readOffset(b, &i); + eprintf("AMB [%04x]", offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_CUT: { + eprintf("CUT"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_BACK: { + eprintf("BACK"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_LET: { + int offset = readOffset(b, &i); + eprintf("LET [%04x]", offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_JMP: { + int offset = readOffset(b, &i); + eprintf("JMP [%04x]", offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_PUSHN: { + int size = readByte(b, &i); + eprintf("PUSHN [%d]", size); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_CALLCC: { + eprintf("CALLCC"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_STDINT_IMAG: { + int val = readInteger(b, &i); + eprintf("STDINT_IMAG [%d]", val); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_STDINT: { + int val = readInteger(b, &i); + eprintf("STDINT [%d]", val); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_BIGINT: { + eprintf("BIGINT ["); + bigint bi = readBigint(b, &i); + bigint_fprint(errout, &bi); + eprintf("]"); + bigint_free(&bi); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_BIGINT_IMAG: { + eprintf("BIGINT_IMAG ["); + bigint bi = readBigint(b, &i); + bigint_fprint(errout, &bi); + eprintf("]"); + loc(ii, &li, l); + bigint_free(&bi); + } break; + case BYTECODES_TYPE_IRRATIONAL: { + Double f = readDouble(b, &i); + eprintf("IRRATIONAL [%f]", f); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_IRRATIONAL_IMAG: { + Double f = readDouble(b, &i); + eprintf("IRRATIONAL_IMAG [%f]", f); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_CHAR: { + Character c = readCharacter(b, &i); + eprintf("CHAR [%s]", charRep(c)); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_RETURN: { + eprintf("RETURN"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_DONE: { + eprintf("DONE"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_ERROR: { + eprintf("ERROR"); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_NS_START: { + int count = readWord(b, &i); + eprintf("NS_START [%d]", count); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_NS_END: { + int numLambdas = readWord(b, &i); + int stackOffset = readWord(b, &i); + eprintf("NS_END [%d][%d]", numLambdas, stackOffset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_NS_FINISH: { + int count = readWord(b, &i); + eprintf("NS_FINISH [%d]", count); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_NS_PUSHSTACK: { + int offset = readWord(b, &i); + eprintf("NS_PUSHSTACK [%d]", offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_NS_PUSHENV: { + int frame = readWord(b, &i); + int offset = readWord(b, &i); + eprintf("NS_PUSHENV [%d][%d]", frame, offset); + loc(ii, &li, l); + } break; + case BYTECODES_TYPE_NS_POP: { + eprintf("NS_POP"); + loc(ii, &li, l); + } break; + default: + cant_happen("unrecognised bytecode %s in dumpByteCode", + byteCodesName(thisByte)); } } } diff --git a/src/main.c b/src/main.c index 7e1eb11c..50625c2a 100644 --- a/src/main.c +++ b/src/main.c @@ -44,6 +44,9 @@ #include "lambda_pp.h" #include "lambda_simplification.h" #include "memory.h" +#include "minlam_beta.h" +#include "minlam_eta.h" +#include "minlam_fold.h" #include "minlam_pp.h" #include "pratt.h" #include "pratt_parser.h" @@ -88,6 +91,8 @@ static char *snippet = NULL; extern StringArray *include_paths; +static int beta_flag = 0; + /** * Report the build mode, i.e. the value of the BUILD_MODE macro when compiled. * @@ -133,7 +138,9 @@ static void usage(char *prog, int status) { " --help This help.\n" " --assertions-accumulate Don't exit on the first assertion " "failure.\n" + " -B\n" " --binary-in= Read byte code from file.\n" + " -O\n" " --binary-out= Write byte code to file.\n" " -a\n" " --dump-alpha Display the intermediate code after " @@ -141,6 +148,9 @@ static void usage(char *prog, int status) { " -a\n" " --dump-alpha= Display the intermediate code after " "alpha-conversion.\n" + " -b\n" + " --dump-beta= Display the intermediate code after " + "beta-conversion.\n" " --dump-anf Display the generated ANF.\n" " --dump-ast Display the parsed AST before lambda " "conversion.\n" @@ -210,13 +220,14 @@ static int processArgs(int argc, char *argv[]) { {"dump-lambda", optional_argument, 0, 'l'}, {"dump-desugared", optional_argument, 0, 'd'}, {"dump-alpha", optional_argument, 0, 'a'}, + {"dump-beta", optional_argument, 0, 'b'}, {"include", required_argument, 0, 'i'}, - {"binary-out", required_argument, 0, 'o'}, - {"binary-in", required_argument, 0, 'b'}, + {"binary-out", required_argument, 0, 'O'}, + {"binary-in", required_argument, 0, 'B'}, {0, 0, 0, 0}}; int option_index = 0; - c = getopt_long(argc, argv, "l::hm:e:i:o:b:d::a::", long_options, + c = getopt_long(argc, argv, "l::hm:e:i:O:B:b::d::a::", long_options, &option_index); if (c == -1) @@ -242,6 +253,14 @@ static int processArgs(int argc, char *argv[]) { } } + if (c == 'b') { + if (optarg) { + beta_conversion_function = optarg; + } else { + beta_flag = 1; + } + } + if (c == 'd') { if (optarg) { desugar_conversion_function = optarg; @@ -250,11 +269,11 @@ static int processArgs(int argc, char *argv[]) { } } - if (c == 'o') { + if (c == 'O') { binary_output_file = optarg; } - if (c == 'b') { + if (c == 'B') { binary_input_file = optarg; } @@ -561,6 +580,23 @@ int main(int argc, char *argv[]) { exit(0); } + minExp = betaMinExp(minExp); + REPLACE_PROTECT(save2, minExp); + + minExp = etaMinExp(minExp); + REPLACE_PROTECT(save2, minExp); + minExp = betaMinExp(minExp); // second pass. + REPLACE_PROTECT(save2, minExp); + + minExp = foldMinExp(minExp); + REPLACE_PROTECT(save2, minExp); + + if (beta_flag) { + ppMinExp(minExp); + eprintf("\n"); + exit(0); + } + AnfExp *anfExp = anfNormalize(minExp); REPLACE_PROTECT(save2, anfExp); diff --git a/src/memory.c b/src/memory.c index 0b540f5d..3ba93c8d 100644 --- a/src/memory.c +++ b/src/memory.c @@ -122,6 +122,8 @@ __attribute__((unused)) static const char *typeName(ObjType type) { return typenameCps_kontObj(type); UTILS_OBJTYPE_CASES() return typenameUtilsObj(type); + TERM_OBJTYPE_CASES() + return typenameTermObj(type); default: { static char buf[64]; snprintf(buf, sizeof(buf), "%d", type); @@ -401,6 +403,9 @@ void markObj(Header *h, Index i) { UTILS_OBJTYPE_CASES() markUtilsObj(h); break; + TERM_OBJTYPE_CASES() + markTermObj(h); + break; default: cant_happen("unrecognised ObjType %d in markObj at [%d]", h->type, i); } @@ -470,6 +475,9 @@ void freeObj(Header *h) { UTILS_OBJTYPE_CASES() freeUtilsObj(h); break; + TERM_OBJTYPE_CASES() + freeTermObj(h); + break; default: cant_happen("unrecognised ObjType %d in freeObj at %p", h->type, (void *)h); diff --git a/src/memory.h b/src/memory.h index ee266e2c..9e77eb1a 100644 --- a/src/memory.h +++ b/src/memory.h @@ -33,6 +33,7 @@ struct Header; #include "minlam_objtypes.h" #include "pratt_objtypes.h" #include "tc_objtypes.h" +#include "term_objtypes.h" #include "tpmc_objtypes.h" #include "types.h" #include "utils_objtypes.h" @@ -66,6 +67,7 @@ typedef enum { ANF_KONT_OBJTYPES(), CPS_KONT_OBJTYPES(), UTILS_OBJTYPES(), + TERM_OBJTYPES(), } ObjType; typedef struct Header { diff --git a/src/minlam.yaml b/src/minlam.yaml index 45f48bf6..3e9ae50e 100644 --- a/src/minlam.yaml +++ b/src/minlam.yaml @@ -190,7 +190,7 @@ unions: data: amb: MinAmb apply: MinApply - args: MinExprList # so that ANF normalize can be uniformly typed + args: MinExprList # only for the alternative ANF normalize_2 path; must not appear in the real MinExp pipeline back: void_ptr bigInteger: MaybeBigInt bindings: MinBindings # so that ANF normalize can be uniformly typed diff --git a/src/minlam_beta.c b/src/minlam_beta.c new file mode 100644 index 00000000..c59d0e8d --- /dev/null +++ b/src/minlam_beta.c @@ -0,0 +1,1005 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + * + * Minimal AST after desugaring + * Generated from src/minlam.yaml by tools/generate.py + */ + +#include "memory.h" +#include "minlam.h" + +#include "minlam_beta.h" +#include "minlam_pp.h" +#include "minlam_subst.h" + +#ifdef DEBUG_MINLAM_BETA +#include "debugging_on.h" +#else +#include "debugging_off.h" +#endif + +static MinLam *betaMinLam(MinLam *node); +static MinExprList *betaMinExprList(MinExprList *node); +static MinPrimApp *betaMinPrimApp(MinPrimApp *node); +static MinExp *betaMinApply(MinExp *node); +static MinLookUp *betaMinLookUp(MinLookUp *node); +static MinIff *betaMinIff(MinIff *node); +static MinCond *betaMinCond(MinCond *node); +static MinIntCondCases *betaMinIntCondCases(MinIntCondCases *node); +static MinCharCondCases *betaMinCharCondCases(MinCharCondCases *node); +static MinMatch *betaMinMatch(MinMatch *node); +static MinMatchList *betaMinMatchList(MinMatchList *node); +static MinIntList *betaMinIntList(MinIntList *node); +static MinLetRec *betaMinLetRec(MinLetRec *node); +static MinBindings *betaMinBindings(MinBindings *node); +static MinAmb *betaMinAmb(MinAmb *node); +static MinAlphaEnv *betaMinAlphaEnv(MinAlphaEnv *node); +static MinCondCases *betaMinCondCases(MinCondCases *node); +static SymbolMap *betaSymbolMap(SymbolMap *node); +static SymbolList *betaSymbolList(SymbolList *node); +static MinNameSpaceArray *betaMinNameSpaceArray(MinNameSpaceArray *node); +static MinAlphaEnvArray *betaMinAlphaEnvArray(MinAlphaEnvArray *node); +static bool isAexp(MinExp *exp); +static bool areAexpList(MinExprList *args); +static bool isIdentityLam(MinLam *lam); + +char *beta_conversion_function = NULL; + +static MinExpTable *makeSubstitutionTable(SymbolList *fargs, + MinExprList *aargs) { + MinExpTable *table = newMinExpTable(); + int save = PROTECT(table); + + while (fargs != NULL && aargs != NULL) { + setMinExpTable(table, fargs->symbol, aargs->exp); + fargs = fargs->next; + aargs = aargs->next; + } + + UNPROTECT(save); + return table; +} + +static bool areAexpList(MinExprList *args) { + while (args != NULL) { + if (!isAexp(args->exp)) { + return false; + } + args = args->next; + } + return true; +} + +static bool isAexp(MinExp *exp) { + if (exp == NULL) { + return false; + } + + switch (exp->type) { + case MINEXP_TYPE_LAM: + case MINEXP_TYPE_VAR: + case MINEXP_TYPE_STDINT: + case MINEXP_TYPE_BIGINTEGER: + case MINEXP_TYPE_CHARACTER: + case MINEXP_TYPE_NAMESPACES: + return true; + case MINEXP_TYPE_PRIM: { + MinPrimApp *prim = getMinExp_Prim(exp); + return isAexp(prim->exp1) && isAexp(prim->exp2); + } + case MINEXP_TYPE_MAKEVEC: + return areAexpList(getMinExp_MakeVec(exp)); + case MINEXP_TYPE_SEQUENCE: + return areAexpList(getMinExp_Sequence(exp)); + case MINEXP_TYPE_LOOKUP: + return isAexp(getMinExp_LookUp(exp)->exp); + default: + return false; + } +} + +static bool isIdentityLam(MinLam *lam) { + if (lam == NULL || lam->args == NULL || lam->args->next != NULL || + lam->exp == NULL) { + return false; + } + if (lam->exp->type != MINEXP_TYPE_VAR) { + return false; + } + return getMinExp_Var(lam->exp) == lam->args->symbol; +} + +////////////////////////// +// Visitor implementations +////////////////////////// + +static MinLam *betaMinLam(MinLam *node) { + ENTER(betaMinLam); + if (node == NULL) { + LEAVE(betaMinLam); + return NULL; + } + + bool changed = false; + SymbolList *new_args = betaSymbolList(node->args); + int save = PROTECT(new_args); + changed = changed || (new_args != node->args); + MinExp *new_exp = betaMinExp(node->exp); + PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + + if (changed) { + MinLam *result = newMinLam(CPI(node), new_args, new_exp); + UNPROTECT(save); + LEAVE(betaMinLam); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinLam); + return node; +} + +static MinExprList *betaMinExprList(MinExprList *node) { + ENTER(betaMinExprList); + if (node == NULL) { + LEAVE(betaMinExprList); + return NULL; + } + + bool changed = false; + MinExp *new_exp = betaMinExp(node->exp); + int save = PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + MinExprList *new_next = betaMinExprList(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinExprList *result = newMinExprList(CPI(node), new_exp, new_next); + UNPROTECT(save); + LEAVE(betaMinExprList); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinExprList); + return node; +} + +static MinPrimApp *betaMinPrimApp(MinPrimApp *node) { + ENTER(betaMinPrimApp); + if (node == NULL) { + LEAVE(betaMinPrimApp); + return NULL; + } + + bool changed = false; + MinExp *new_exp1 = betaMinExp(node->exp1); + int save = PROTECT(new_exp1); + changed = changed || (new_exp1 != node->exp1); + MinExp *new_exp2 = betaMinExp(node->exp2); + PROTECT(new_exp2); + changed = changed || (new_exp2 != node->exp2); + + if (changed) { + MinPrimApp *result = + newMinPrimApp(CPI(node), node->type, new_exp1, new_exp2); + UNPROTECT(save); + LEAVE(betaMinPrimApp); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinPrimApp); + return node; +} + +// too many args +// ((λ (f1) body) a1 a2) => reduce(body[f1/a1] a2) +static MinExp *betaMinOverApply(MinExp *body, SymbolList *fargs, + MinExprList *aargs) { +#if 0 + body = betaMinExp(body); + int save = PROTECT(body); + MinExp *lam = makeMinExp_Lam(CPI(body), fargs, body); + PROTECT(lam); + MinExp *result = makeMinExp_Apply(CPI(body), lam, aargs); + UNPROTECT(save); + return result; +#else + // implicitly creates the short list [f1/a1] + MinExpTable *table = makeSubstitutionTable(fargs, aargs); + int save = PROTECT(table); + body = substMinExp(body, table); + PROTECT(body); + + for (int i = countSymbolList(fargs); i > 0; i--) { + aargs = aargs->next; + } + + MinExp *result = makeMinExp_Apply(CPI(body), body, aargs); + PROTECT(result); + result = betaMinExp(result); + UNPROTECT(save); + return result; +#endif +} + +// too few args +// ((λ (f1 f2) body) a1) => (λ (f2) body[f1/a1]) +static MinExp *betaMinUnderApply(MinExp *body, SymbolList *fargs, + MinExprList *aargs) { +#if 0 + body = betaMinExp(body); + int save = PROTECT(body); + MinExp *lam = makeMinExp_Lam(CPI(body), fargs, body); + PROTECT(lam); + MinExp *result = makeMinExp_Apply(CPI(body), lam, aargs); + UNPROTECT(save); + return result; +#else + MinExpTable *table = makeSubstitutionTable(fargs, aargs); + int save = PROTECT(table); + body = substMinExp(body, table); + PROTECT(body); + + // step past the substituted fargs to f2 + for (int i = countMinExprList(aargs); i > 0; i--) { + fargs = fargs->next; + } + + MinExp *result = makeMinExp_Lam(CPI(body), fargs, body); + UNPROTECT(save); + return result; +#endif +} + +// same number of args +// ((λ (f1 f2) body) a1 a2) => reduce(body[f1/a1, f2/a2]) +static MinExp *betaMinSimpleApply(MinExp *body, SymbolList *fargs, + MinExprList *aargs) { + MinExpTable *table = makeSubstitutionTable(fargs, aargs); + int save = PROTECT(table); + body = substMinExp(body, table); + PROTECT(body); + body = betaMinExp(body); + UNPROTECT(save); + return body; +} + +static MinExp *betaMinApplyLambda(MinLam *lam, MinExprList *aargs) { + int num_aargs = countMinExprList(aargs); + SymbolList *fargs = lam->args; + int num_fargs = countSymbolList(fargs); + + // Exact nullary application is safe to collapse directly: there are no + // arguments to substitute, so no risk of duplicating/reordering argument + // evaluation. + if (num_aargs == 0 && num_fargs == 0) { + return betaMinExp(lam->exp); + } + + if (num_aargs <= 0 || num_fargs <= 0) { + return NULL; + } + + // Conservative extension: exact identity application can be reduced even + // when the argument is not an A-expression because it does not duplicate + // or discard the argument. + if (num_fargs == 1 && num_aargs == 1 && isIdentityLam(lam)) { + return aargs->exp; + } + + // Safety rule for this pass: only beta-reduce when each substituted + // argument is an A-expression. + // + // This compiler evaluates function arguments before call (call-by-value). + // Unrestricted substitution can duplicate or delay non-value arguments, + // changing observable behavior for effects and control operators such as + // amb/backtracking, call/cc, I/O, and namespace lookups. + // + // For now we only substitute a prefix of arguments when all substituted + // arguments are A-expressions. Otherwise we leave the APPLY shape + // intact and only recurse into children. + int substitutions = num_fargs < num_aargs ? num_fargs : num_aargs; + MinExprList *cur = aargs; + for (int i = 0; i < substitutions; i++) { + if (cur == NULL || !isAexp(cur->exp)) { + return NULL; + } + cur = cur->next; + } + + if (num_fargs < num_aargs) { + return betaMinOverApply(lam->exp, fargs, aargs); + } else if (num_fargs > num_aargs) { + return betaMinUnderApply(lam->exp, fargs, aargs); + } else { + return betaMinSimpleApply(lam->exp, fargs, aargs); + } +} + +// N.B. MinExp not MinApply so it can return a different type. +static MinExp *betaMinApply(MinExp *exp) { + ENTER(betaMinApply); + if (exp == NULL) { + LEAVE(betaMinApply); + return NULL; + } + + MinApply *node = getMinExp_Apply(exp); + + bool changed = false; + MinExprList *redaargs = betaMinExprList(node->args); + int save = PROTECT(redaargs); + changed = changed || (redaargs != node->args); + + MinExp *new_function = betaMinExp(node->function); + PROTECT(new_function); + changed = changed || (new_function != node->function); + + if (new_function->type == MINEXP_TYPE_LAM) { + MinExp *result = + betaMinApplyLambda(getMinExp_Lam(new_function), redaargs); + if (result != NULL) { + UNPROTECT(save); + LEAVE(betaMinApply); + return result; + } + } + + if (changed) { + MinExp *result = makeMinExp_Apply(CPI(node), new_function, redaargs); + UNPROTECT(save); + LEAVE(betaMinApply); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinApply); + return exp; +} + +static MinLookUp *betaMinLookUp(MinLookUp *node) { + ENTER(betaMinLookUp); + if (node == NULL) { + LEAVE(betaMinLookUp); + return NULL; + } + + bool changed = false; + MinExp *new_exp = betaMinExp(node->exp); + int save = PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + + if (changed) { + MinLookUp *result = newMinLookUp(CPI(node), node->nsId, new_exp); + UNPROTECT(save); + LEAVE(betaMinLookUp); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinLookUp); + return node; +} + +static MinIff *betaMinIff(MinIff *node) { + ENTER(betaMinIff); + if (node == NULL) { + LEAVE(betaMinIff); + return NULL; + } + + bool changed = false; + MinExp *new_condition = betaMinExp(node->condition); + int save = PROTECT(new_condition); + changed = changed || (new_condition != node->condition); + MinExp *new_consequent = betaMinExp(node->consequent); + PROTECT(new_consequent); + changed = changed || (new_consequent != node->consequent); + MinExp *new_alternative = betaMinExp(node->alternative); + PROTECT(new_alternative); + changed = changed || (new_alternative != node->alternative); + + if (changed) { + MinIff *result = newMinIff(CPI(node), new_condition, new_consequent, + new_alternative); + UNPROTECT(save); + LEAVE(betaMinIff); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinIff); + return node; +} + +static MinCond *betaMinCond(MinCond *node) { + ENTER(betaMinCond); + if (node == NULL) { + LEAVE(betaMinCond); + return NULL; + } + + bool changed = false; + MinExp *new_value = betaMinExp(node->value); + int save = PROTECT(new_value); + changed = changed || (new_value != node->value); + MinCondCases *new_cases = betaMinCondCases(node->cases); + PROTECT(new_cases); + changed = changed || (new_cases != node->cases); + + if (changed) { + MinCond *result = newMinCond(CPI(node), new_value, new_cases); + UNPROTECT(save); + LEAVE(betaMinCond); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinCond); + return node; +} + +static MinIntCondCases *betaMinIntCondCases(MinIntCondCases *node) { + ENTER(betaMinIntCondCases); + if (node == NULL) { + LEAVE(betaMinIntCondCases); + return NULL; + } + + bool changed = false; + MinExp *new_body = betaMinExp(node->body); + int save = PROTECT(new_body); + changed = changed || (new_body != node->body); + MinIntCondCases *new_next = betaMinIntCondCases(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinIntCondCases *result = + newMinIntCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + LEAVE(betaMinIntCondCases); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinIntCondCases); + return node; +} + +static MinCharCondCases *betaMinCharCondCases(MinCharCondCases *node) { + ENTER(betaMinCharCondCases); + if (node == NULL) { + LEAVE(betaMinCharCondCases); + return NULL; + } + + bool changed = false; + MinExp *new_body = betaMinExp(node->body); + int save = PROTECT(new_body); + changed = changed || (new_body != node->body); + MinCharCondCases *new_next = betaMinCharCondCases(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinCharCondCases *result = + newMinCharCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + LEAVE(betaMinCharCondCases); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinCharCondCases); + return node; +} + +static MinMatch *betaMinMatch(MinMatch *node) { + ENTER(betaMinMatch); + if (node == NULL) { + LEAVE(betaMinMatch); + return NULL; + } + + bool changed = false; + MinExp *new_index = betaMinExp(node->index); + int save = PROTECT(new_index); + changed = changed || (new_index != node->index); + MinMatchList *new_cases = betaMinMatchList(node->cases); + PROTECT(new_cases); + changed = changed || (new_cases != node->cases); + + if (changed) { + MinMatch *result = newMinMatch(CPI(node), new_index, new_cases); + UNPROTECT(save); + LEAVE(betaMinMatch); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinMatch); + return node; +} + +static MinMatchList *betaMinMatchList(MinMatchList *node) { + ENTER(betaMinMatchList); + if (node == NULL) { + LEAVE(betaMinMatchList); + return NULL; + } + + bool changed = false; + MinIntList *new_matches = betaMinIntList(node->matches); + int save = PROTECT(new_matches); + changed = changed || (new_matches != node->matches); + MinExp *new_body = betaMinExp(node->body); + PROTECT(new_body); + changed = changed || (new_body != node->body); + MinMatchList *new_next = betaMinMatchList(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinMatchList *result = + newMinMatchList(CPI(node), new_matches, new_body, new_next); + UNPROTECT(save); + LEAVE(betaMinMatchList); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinMatchList); + return node; +} + +static MinIntList *betaMinIntList(MinIntList *node) { + ENTER(betaMinIntList); + if (node == NULL) { + LEAVE(betaMinIntList); + return NULL; + } + + bool changed = false; + MinIntList *new_next = betaMinIntList(node->next); + int save = PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinIntList *result = newMinIntList(CPI(node), node->item, new_next); + UNPROTECT(save); + LEAVE(betaMinIntList); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinIntList); + return node; +} + +static MinLetRec *betaMinLetRec(MinLetRec *node) { + ENTER(betaMinLetRec); + if (node == NULL) { + LEAVE(betaMinLetRec); + return NULL; + } + + bool changed = false; + MinBindings *new_bindings = betaMinBindings(node->bindings); + int save = PROTECT(new_bindings); + changed = changed || (new_bindings != node->bindings); + MinExp *new_body = betaMinExp(node->body); + PROTECT(new_body); + changed = changed || (new_body != node->body); + + if (changed) { + MinLetRec *result = newMinLetRec(CPI(node), new_bindings, new_body); + UNPROTECT(save); + LEAVE(betaMinLetRec); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinLetRec); + return node; +} + +static MinBindings *betaMinBindings(MinBindings *node) { + ENTER(betaMinBindings); + if (node == NULL) { + LEAVE(betaMinBindings); + return NULL; + } + + bool changed = false; + MinExp *new_val = betaMinExp(node->val); + int save = PROTECT(new_val); + changed = changed || (new_val != node->val); + MinBindings *new_next = betaMinBindings(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + node = newMinBindings(CPI(node), node->var, new_val, new_next); + } + + if (beta_conversion_function != NULL && + strcmp(beta_conversion_function, node->var->name) == 0) { + ppMinExp(new_val); + } + + UNPROTECT(save); + LEAVE(betaMinBindings); + return node; +} + +static MinAmb *betaMinAmb(MinAmb *node) { + ENTER(betaMinAmb); + if (node == NULL) { + LEAVE(betaMinAmb); + return NULL; + } + + bool changed = false; + MinExp *new_left = betaMinExp(node->left); + int save = PROTECT(new_left); + changed = changed || (new_left != node->left); + MinExp *new_right = betaMinExp(node->right); + PROTECT(new_right); + changed = changed || (new_right != node->right); + + if (changed) { + MinAmb *result = newMinAmb(CPI(node), new_left, new_right); + UNPROTECT(save); + LEAVE(betaMinAmb); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinAmb); + return node; +} + +static MinAlphaEnv *betaMinAlphaEnv(MinAlphaEnv *node) { + ENTER(betaMinAlphaEnv); + if (node == NULL) { + LEAVE(betaMinAlphaEnv); + return NULL; + } + + bool changed = false; + SymbolMap *new_alphaTable = betaSymbolMap(node->alphaTable); + int save = PROTECT(new_alphaTable); + changed = changed || (new_alphaTable != node->alphaTable); + MinAlphaEnv *new_next = betaMinAlphaEnv(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + MinAlphaEnvArray *new_nameSpaces = betaMinAlphaEnvArray(node->nameSpaces); + PROTECT(new_nameSpaces); + changed = changed || (new_nameSpaces != node->nameSpaces); + + if (changed) { + MinAlphaEnv *result = newMinAlphaEnv(new_next); + result->alphaTable = new_alphaTable; + result->nameSpaces = new_nameSpaces; + UNPROTECT(save); + LEAVE(betaMinAlphaEnv); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinAlphaEnv); + return node; +} + +MinExp *betaMinExp(MinExp *node) { + ENTER(betaMinExp); + if (node == NULL) { + LEAVE(betaMinExp); + return NULL; + } + + int save = PROTECT(NULL); + MinExp *result = node; + + switch (node->type) { + case MINEXP_TYPE_AMB: { + MinAmb *variant = getMinExp_Amb(node); + MinAmb *new_variant = betaMinAmb(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Amb(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_APPLY: { + result = betaMinApply(node); + break; + } + case MINEXP_TYPE_BACK: { + break; + } + case MINEXP_TYPE_BIGINTEGER: { + break; + } + case MINEXP_TYPE_CALLCC: { + MinExp *variant = getMinExp_CallCC(node); + MinExp *new_variant = betaMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_CallCC(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_CHARACTER: { + break; + } + case MINEXP_TYPE_COND: { + MinCond *variant = getMinExp_Cond(node); + MinCond *new_variant = betaMinCond(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cond(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_ENV: { + break; + } + case MINEXP_TYPE_ERROR: { + break; + } + case MINEXP_TYPE_IFF: { + MinIff *variant = getMinExp_Iff(node); + MinIff *new_variant = betaMinIff(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Iff(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LAM: { + MinLam *variant = getMinExp_Lam(node); + MinLam *new_variant = betaMinLam(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Lam(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LETREC: { + MinLetRec *variant = getMinExp_LetRec(node); + MinLetRec *new_variant = betaMinLetRec(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LetRec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LOOKUP: { + MinLookUp *variant = getMinExp_LookUp(node); + MinLookUp *new_variant = betaMinLookUp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LookUp(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MAKEVEC: { + MinExprList *variant = getMinExp_MakeVec(node); + MinExprList *new_variant = betaMinExprList(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_MakeVec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MATCH: { + MinMatch *variant = getMinExp_Match(node); + MinMatch *new_variant = betaMinMatch(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Match(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_NAMESPACES: { + MinNameSpaceArray *variant = getMinExp_NameSpaces(node); + MinNameSpaceArray *new_variant = betaMinNameSpaceArray(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_NameSpaces(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_PRIM: { + MinPrimApp *variant = getMinExp_Prim(node); + MinPrimApp *new_variant = betaMinPrimApp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Prim(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_SEQUENCE: { + MinExprList *variant = getMinExp_Sequence(node); + MinExprList *new_variant = betaMinExprList(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Sequence(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_STDINT: { + break; + } + case MINEXP_TYPE_VAR: { + break; + } + default: + cant_happen("unrecognized MinExp type %d", node->type); + } + + UNPROTECT(save); + LEAVE(betaMinExp); + return result; +} + +static MinCondCases *betaMinCondCases(MinCondCases *node) { + ENTER(betaMinCondCases); + if (node == NULL) { + LEAVE(betaMinCondCases); + return NULL; + } + + int save = PROTECT(NULL); + MinCondCases *result = node; + + switch (node->type) { + case MINCONDCASES_TYPE_INTEGERS: { + MinIntCondCases *variant = getMinCondCases_Integers(node); + MinIntCondCases *new_variant = betaMinIntCondCases(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Integers(CPI(node), new_variant); + } + break; + } + case MINCONDCASES_TYPE_CHARACTERS: { + MinCharCondCases *variant = getMinCondCases_Characters(node); + MinCharCondCases *new_variant = betaMinCharCondCases(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Characters(CPI(node), new_variant); + } + break; + } + default: + cant_happen("unrecognized MinCondCases type %d", node->type); + } + + UNPROTECT(save); + LEAVE(betaMinCondCases); + return result; +} + +static SymbolMap *betaSymbolMap(SymbolMap *node) { + ENTER(betaSymbolMap); + if (node == NULL) { + LEAVE(betaSymbolMap); + return NULL; + } + +#ifdef NOTDEF + Index i = 0; + struct HashSymbol *value; + HashSymbol *key; + while ((key = iterateSymbolMap(node, &i, &value)) != NULL) { + // Inspect/log key and value here + } +#endif + LEAVE(betaSymbolMap); + return node; +} + +static SymbolList *betaSymbolList(SymbolList *node) { + ENTER(betaSymbolList); + if (node == NULL) { + LEAVE(betaSymbolList); + return NULL; + } + + bool changed = false; + SymbolList *new_next = betaSymbolList(node->next); + int save = PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + SymbolList *result = newSymbolList(CPI(node), node->symbol, new_next); + UNPROTECT(save); + LEAVE(betaSymbolList); + return result; + } + + UNPROTECT(save); + LEAVE(betaSymbolList); + return node; +} + +static MinNameSpaceArray *betaMinNameSpaceArray(MinNameSpaceArray *node) { + ENTER(betaMinNameSpaceArray); + if (node == NULL) { + LEAVE(betaMinNameSpaceArray); + return NULL; + } + + bool changed = false; + MinNameSpaceArray *result = newMinNameSpaceArray(); + int save = PROTECT(result); + + for (Index i = 0; i < node->size; i++) { + struct MinExp *element = peeknMinNameSpaceArray(node, i); + struct MinExp *new_element = betaMinExp(element); + PROTECT(new_element); + changed = changed || (new_element != element); + pushMinNameSpaceArray(result, new_element); + } + + if (changed) { + UNPROTECT(save); + LEAVE(betaMinNameSpaceArray); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinNameSpaceArray); + return node; +} + +static MinAlphaEnvArray *betaMinAlphaEnvArray(MinAlphaEnvArray *node) { + ENTER(betaMinAlphaEnvArray); + if (node == NULL) { + LEAVE(betaMinAlphaEnvArray); + return NULL; + } + + bool changed = false; + MinAlphaEnvArray *result = newMinAlphaEnvArray(); + int save = PROTECT(result); + + for (Index i = 0; i < node->size; i++) { + struct MinAlphaEnv *element = peeknMinAlphaEnvArray(node, i); + struct MinAlphaEnv *new_element = betaMinAlphaEnv(element); + PROTECT(new_element); + changed = changed || (new_element != element); + pushMinAlphaEnvArray(result, new_element); + } + + if (changed) { + UNPROTECT(save); + LEAVE(betaMinAlphaEnvArray); + return result; + } + + UNPROTECT(save); + LEAVE(betaMinAlphaEnvArray); + return node; +} diff --git a/src/minlam_beta.h b/src/minlam_beta.h new file mode 100644 index 00000000..40599710 --- /dev/null +++ b/src/minlam_beta.h @@ -0,0 +1,24 @@ +#ifndef cekf_minlam_beta_h +#define cekf_minlam_beta_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +MinExp *betaMinExp(MinExp *node); +extern char *beta_conversion_function; + +#endif diff --git a/src/minlam_eta.c b/src/minlam_eta.c new file mode 100644 index 00000000..471187e2 --- /dev/null +++ b/src/minlam_eta.c @@ -0,0 +1,769 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + * + * Minimal AST after desugaring + * Generated from src/minlam.yaml by tools/generate.py + */ + +#include "minlam_eta.h" +#include "memory.h" +#include "minlam.h" +#include "minlam_occurs.h" +#include "utils_helper.h" + +#ifdef DEBUG_MINLAM_ETA +#include "debugging_on.h" +#else +#include "debugging_off.h" +#endif + +static MinExp *etaMinLam(MinExp *node); +static MinExprList *etaMinExprList(MinExprList *node); +static MinPrimApp *etaMinPrimApp(MinPrimApp *node); +static MinApply *etaMinApply(MinApply *node); +static MinLookUp *etaMinLookUp(MinLookUp *node); +static MinIff *etaMinIff(MinIff *node); +static MinCond *etaMinCond(MinCond *node); +static MinIntCondCases *etaMinIntCondCases(MinIntCondCases *node); +static MinCharCondCases *etaMinCharCondCases(MinCharCondCases *node); +static MinMatch *etaMinMatch(MinMatch *node); +static MinMatchList *etaMinMatchList(MinMatchList *node); +static MinLetRec *etaMinLetRec(MinLetRec *node); +static MinBindings *etaMinBindings(MinBindings *node); +static MinAmb *etaMinAmb(MinAmb *node); +static MinCondCases *etaMinCondCases(MinCondCases *node); +static MinNameSpaceArray *etaMinNameSpaceArray(MinNameSpaceArray *node); +static bool etaSafeFunction(MinExp *exp); +static MinExp *etaMinBindingValue(MinExp *exp); +static SymbolSet *etaBindingSymbols(MinBindings *node); + +static SymbolSet *etaLetRecSymbols = NULL; + +// true if aargs are all symbols and the same symbols as fargs. +static bool fargsEqAargs(SymbolList *fargs, MinExprList *aargs) { + if (fargs == NULL) { + return aargs == NULL; + } else if (aargs == NULL) { + return false; + } else { + if (!isMinExp_Var(aargs->exp)) { + return false; + } + return fargs->symbol == getMinExp_Var(aargs->exp) && + fargsEqAargs(fargs->next, aargs->next); + } +} + +static bool etaSafeFunction(MinExp *exp) { return exp != NULL; } + +static SymbolSet *etaBindingSymbols(MinBindings *node) { + ENTER(etaBindingSymbols); + SymbolSet *symbols = newSymbolSet(); + int save = PROTECT(symbols); + while (node != NULL) { + setSymbolSet(symbols, node->var); + node = node->next; + } + UNPROTECT(save); + LEAVE(etaBindingSymbols); + return symbols; +} + +static MinExp *etaMinBindingValue(MinExp *exp) { + ENTER(etaMinBindingValue); + if (exp == NULL) { + LEAVE(etaMinBindingValue); + return NULL; + } + + if (!isMinExp_Lam(exp)) { + LEAVE(etaMinBindingValue); + return exp; + } + + MinLam *lambda = getMinExp_Lam(exp); + MinExp *new_body = etaMinExp(lambda->exp); + + if (new_body != lambda->exp) { + int save = PROTECT(new_body); + MinExp *result = makeMinExp_Lam(CPI(lambda), lambda->args, new_body); + UNPROTECT(save); + LEAVE(etaMinBindingValue); + return result; + } + + LEAVE(etaMinBindingValue); + return exp; +} + +////////////////////////// +// Visitor implementations +////////////////////////// + +// N.B. MinExp not MinLam +static MinExp *etaMinLam(MinExp *exp) { + ENTER(etaMinLam); + MinLam *lambda = getMinExp_Lam(exp); + + if (lambda == NULL) { + LEAVE(etaMinLam); + return NULL; + } + + // η(λ.x (f x))) => ηf, where x is not free in f + if (lambda->exp != NULL && isMinExp_Apply(lambda->exp)) { + MinApply *apply = getMinExp_Apply(lambda->exp); // (f x) + if (etaSafeFunction(apply->function) && + fargsEqAargs(lambda->args, apply->args)) { + SymbolSet *symbols = symbolListToSet(lambda->args); + int save = PROTECT(symbols); + bool touchesLetRec = + etaLetRecSymbols != NULL && + occursMinExp(apply->function, etaLetRecSymbols); + if (!touchesLetRec && !occursMinExp(apply->function, symbols)) { + MinExp *result = etaMinExp(apply->function); // ηf + UNPROTECT(save); + LEAVE(etaMinLam); + return result; + } + UNPROTECT(save); + } + } + + // η(λ.x (f x))) => (λ.x (ηf x)) otherwise + MinExp *body = etaMinExp(lambda->exp); + if (body != lambda->exp) { + int save = PROTECT(body); + MinExp *result = makeMinExp_Lam(CPI(lambda), lambda->args, body); + UNPROTECT(save); + LEAVE(etaMinLam); + return result; + } + + LEAVE(etaMinLam); + return exp; +} + +static MinExprList *etaMinExprList(MinExprList *node) { + ENTER(etaMinExprList); + if (node == NULL) { + LEAVE(etaMinExprList); + return NULL; + } + + bool changed = false; + MinExp *new_exp = etaMinExp(node->exp); + int save = PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + MinExprList *new_next = etaMinExprList(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinExprList *result = newMinExprList(CPI(node), new_exp, new_next); + UNPROTECT(save); + LEAVE(etaMinExprList); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinExprList); + return node; +} + +static MinPrimApp *etaMinPrimApp(MinPrimApp *node) { + ENTER(etaMinPrimApp); + if (node == NULL) { + LEAVE(etaMinPrimApp); + return NULL; + } + + bool changed = false; + MinExp *new_exp1 = etaMinExp(node->exp1); + int save = PROTECT(new_exp1); + changed = changed || (new_exp1 != node->exp1); + MinExp *new_exp2 = etaMinExp(node->exp2); + PROTECT(new_exp2); + changed = changed || (new_exp2 != node->exp2); + + if (changed) { + MinPrimApp *result = + newMinPrimApp(CPI(node), node->type, new_exp1, new_exp2); + UNPROTECT(save); + LEAVE(etaMinPrimApp); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinPrimApp); + return node; +} + +static MinApply *etaMinApply(MinApply *node) { + ENTER(etaMinApply); + if (node == NULL) { + LEAVE(etaMinApply); + return NULL; + } + + bool changed = false; + MinExp *new_function = etaMinExp(node->function); + int save = PROTECT(new_function); + changed = changed || (new_function != node->function); + MinExprList *new_args = etaMinExprList(node->args); + PROTECT(new_args); + changed = changed || (new_args != node->args); + + if (changed) { + MinApply *result = newMinApply(CPI(node), new_function, new_args); + UNPROTECT(save); + LEAVE(etaMinApply); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinApply); + return node; +} + +static MinLookUp *etaMinLookUp(MinLookUp *node) { + ENTER(etaMinLookUp); + if (node == NULL) { + LEAVE(etaMinLookUp); + return NULL; + } + + bool changed = false; + MinExp *new_exp = etaMinExp(node->exp); + int save = PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + + if (changed) { + MinLookUp *result = newMinLookUp(CPI(node), node->nsId, new_exp); + UNPROTECT(save); + LEAVE(etaMinLookUp); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinLookUp); + return node; +} + +static MinIff *etaMinIff(MinIff *node) { + ENTER(etaMinIff); + if (node == NULL) { + LEAVE(etaMinIff); + return NULL; + } + + bool changed = false; + MinExp *new_condition = etaMinExp(node->condition); + int save = PROTECT(new_condition); + changed = changed || (new_condition != node->condition); + MinExp *new_consequent = etaMinExp(node->consequent); + PROTECT(new_consequent); + changed = changed || (new_consequent != node->consequent); + MinExp *new_alternative = etaMinExp(node->alternative); + PROTECT(new_alternative); + changed = changed || (new_alternative != node->alternative); + + if (changed) { + MinIff *result = newMinIff(CPI(node), new_condition, new_consequent, + new_alternative); + UNPROTECT(save); + LEAVE(etaMinIff); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinIff); + return node; +} + +static MinCond *etaMinCond(MinCond *node) { + ENTER(etaMinCond); + if (node == NULL) { + LEAVE(etaMinCond); + return NULL; + } + + bool changed = false; + MinExp *new_value = etaMinExp(node->value); + int save = PROTECT(new_value); + changed = changed || (new_value != node->value); + MinCondCases *new_cases = etaMinCondCases(node->cases); + PROTECT(new_cases); + changed = changed || (new_cases != node->cases); + + if (changed) { + MinCond *result = newMinCond(CPI(node), new_value, new_cases); + UNPROTECT(save); + LEAVE(etaMinCond); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinCond); + return node; +} + +static MinIntCondCases *etaMinIntCondCases(MinIntCondCases *node) { + ENTER(etaMinIntCondCases); + if (node == NULL) { + LEAVE(etaMinIntCondCases); + return NULL; + } + + bool changed = false; + MinExp *new_body = etaMinExp(node->body); + int save = PROTECT(new_body); + changed = changed || (new_body != node->body); + MinIntCondCases *new_next = etaMinIntCondCases(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinIntCondCases *result = + newMinIntCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + LEAVE(etaMinIntCondCases); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinIntCondCases); + return node; +} + +static MinCharCondCases *etaMinCharCondCases(MinCharCondCases *node) { + ENTER(etaMinCharCondCases); + if (node == NULL) { + LEAVE(etaMinCharCondCases); + return NULL; + } + + bool changed = false; + MinExp *new_body = etaMinExp(node->body); + int save = PROTECT(new_body); + changed = changed || (new_body != node->body); + MinCharCondCases *new_next = etaMinCharCondCases(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinCharCondCases *result = + newMinCharCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + LEAVE(etaMinCharCondCases); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinCharCondCases); + return node; +} + +static MinMatch *etaMinMatch(MinMatch *node) { + ENTER(etaMinMatch); + if (node == NULL) { + LEAVE(etaMinMatch); + return NULL; + } + + bool changed = false; + MinExp *new_index = etaMinExp(node->index); + int save = PROTECT(new_index); + changed = changed || (new_index != node->index); + MinMatchList *new_cases = etaMinMatchList(node->cases); + PROTECT(new_cases); + changed = changed || (new_cases != node->cases); + + if (changed) { + MinMatch *result = newMinMatch(CPI(node), new_index, new_cases); + UNPROTECT(save); + LEAVE(etaMinMatch); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinMatch); + return node; +} + +static MinMatchList *etaMinMatchList(MinMatchList *node) { + ENTER(etaMinMatchList); + if (node == NULL) { + LEAVE(etaMinMatchList); + return NULL; + } + + bool changed = false; + MinExp *new_body = etaMinExp(node->body); + int save = PROTECT(new_body); + changed = changed || (new_body != node->body); + MinMatchList *new_next = etaMinMatchList(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinMatchList *result = + newMinMatchList(CPI(node), node->matches, new_body, new_next); + UNPROTECT(save); + LEAVE(etaMinMatchList); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinMatchList); + return node; +} + +static MinLetRec *etaMinLetRec(MinLetRec *node) { + ENTER(etaMinLetRec); + if (node == NULL) { + LEAVE(etaMinLetRec); + return NULL; + } + + int save = PROTECT(NULL); + SymbolSet *previousLetRecSymbols = etaLetRecSymbols; + SymbolSet *bindingSymbols = etaBindingSymbols(node->bindings); + PROTECT(bindingSymbols); + if (previousLetRecSymbols != NULL) { + bindingSymbols = unionSymbolSet(previousLetRecSymbols, bindingSymbols); + PROTECT(bindingSymbols); + } + etaLetRecSymbols = bindingSymbols; + + bool changed = false; + MinBindings *new_bindings = etaMinBindings(node->bindings); + PROTECT(new_bindings); + changed = changed || (new_bindings != node->bindings); + MinExp *new_body = etaMinExp(node->body); + PROTECT(new_body); + changed = changed || (new_body != node->body); + + etaLetRecSymbols = previousLetRecSymbols; + + if (changed) { + MinLetRec *result = newMinLetRec(CPI(node), new_bindings, new_body); + UNPROTECT(save); + LEAVE(etaMinLetRec); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinLetRec); + return node; +} + +static MinBindings *etaMinBindings(MinBindings *node) { + ENTER(etaMinBindings); + if (node == NULL) { + LEAVE(etaMinBindings); + return NULL; + } + + bool changed = false; + // LetRec bindings are scope-sensitive for later normalization/annotation. + // Preserve binding shape, but allow eta reduction inside lambda bodies. + MinExp *new_val = etaMinBindingValue(node->val); + int save = PROTECT(new_val); + changed = changed || (new_val != node->val); + MinBindings *new_next = etaMinBindings(node->next); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + MinBindings *result = + newMinBindings(CPI(node), node->var, new_val, new_next); + UNPROTECT(save); + LEAVE(etaMinBindings); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinBindings); + return node; +} + +static MinAmb *etaMinAmb(MinAmb *node) { + ENTER(etaMinAmb); + if (node == NULL) { + LEAVE(etaMinAmb); + return NULL; + } + + bool changed = false; + MinExp *new_left = etaMinExp(node->left); + int save = PROTECT(new_left); + changed = changed || (new_left != node->left); + MinExp *new_right = etaMinExp(node->right); + PROTECT(new_right); + changed = changed || (new_right != node->right); + + if (changed) { + MinAmb *result = newMinAmb(CPI(node), new_left, new_right); + UNPROTECT(save); + LEAVE(etaMinAmb); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinAmb); + return node; +} + +MinExp *etaMinExp(MinExp *node) { + ENTER(etaMinExp); + if (node == NULL) { + LEAVE(etaMinExp); + return NULL; + } + + int save = PROTECT(NULL); + MinExp *result = node; + + switch (node->type) { + case MINEXP_TYPE_AMB: { + MinAmb *variant = getMinExp_Amb(node); + MinAmb *new_variant = etaMinAmb(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Amb(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_APPLY: { + MinApply *variant = getMinExp_Apply(node); + MinApply *new_variant = etaMinApply(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Apply(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_ARGS: { + MinExprList *variant = getMinExp_Args(node); + MinExprList *new_variant = etaMinExprList(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Args(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_BACK: { + break; + } + case MINEXP_TYPE_BIGINTEGER: { + break; + } + case MINEXP_TYPE_BINDINGS: { + MinBindings *variant = getMinExp_Bindings(node); + MinBindings *new_variant = etaMinBindings(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Bindings(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_CALLCC: { + MinExp *variant = getMinExp_CallCC(node); + MinExp *new_variant = etaMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_CallCC(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_CHARACTER: { + break; + } + case MINEXP_TYPE_COND: { + MinCond *variant = getMinExp_Cond(node); + MinCond *new_variant = etaMinCond(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cond(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_ENV: { + break; + } + case MINEXP_TYPE_ERROR: { + break; + } + case MINEXP_TYPE_IFF: { + MinIff *variant = getMinExp_Iff(node); + MinIff *new_variant = etaMinIff(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Iff(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LAM: { + result = etaMinLam(node); + break; + } + case MINEXP_TYPE_LETREC: { + MinLetRec *variant = getMinExp_LetRec(node); + MinLetRec *new_variant = etaMinLetRec(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LetRec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LOOKUP: { + MinLookUp *variant = getMinExp_LookUp(node); + MinLookUp *new_variant = etaMinLookUp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LookUp(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MAKEVEC: { + MinExprList *variant = getMinExp_MakeVec(node); + MinExprList *new_variant = etaMinExprList(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_MakeVec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MATCH: { + MinMatch *variant = getMinExp_Match(node); + MinMatch *new_variant = etaMinMatch(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Match(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_NAMESPACES: { + MinNameSpaceArray *variant = getMinExp_NameSpaces(node); + MinNameSpaceArray *new_variant = etaMinNameSpaceArray(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_NameSpaces(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_PRIM: { + MinPrimApp *variant = getMinExp_Prim(node); + MinPrimApp *new_variant = etaMinPrimApp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Prim(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_SEQUENCE: { + MinExprList *variant = getMinExp_Sequence(node); + MinExprList *new_variant = etaMinExprList(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Sequence(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_STDINT: { + break; + } + case MINEXP_TYPE_VAR: { + break; + } + default: + cant_happen("unrecognized MinExp type %d", node->type); + } + + UNPROTECT(save); + LEAVE(etaMinExp); + return result; +} + +static MinCondCases *etaMinCondCases(MinCondCases *node) { + ENTER(etaMinCondCases); + if (node == NULL) { + LEAVE(etaMinCondCases); + return NULL; + } + + int save = PROTECT(NULL); + MinCondCases *result = node; + + switch (node->type) { + case MINCONDCASES_TYPE_INTEGERS: { + MinIntCondCases *variant = getMinCondCases_Integers(node); + MinIntCondCases *new_variant = etaMinIntCondCases(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Integers(CPI(node), new_variant); + } + break; + } + case MINCONDCASES_TYPE_CHARACTERS: { + MinCharCondCases *variant = getMinCondCases_Characters(node); + MinCharCondCases *new_variant = etaMinCharCondCases(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Characters(CPI(node), new_variant); + } + break; + } + default: + cant_happen("unrecognized MinCondCases type %d", node->type); + } + + UNPROTECT(save); + LEAVE(etaMinCondCases); + return result; +} + +static MinNameSpaceArray *etaMinNameSpaceArray(MinNameSpaceArray *node) { + ENTER(etaMinNameSpaceArray); + if (node == NULL) { + LEAVE(etaMinNameSpaceArray); + return NULL; + } + + bool changed = false; + MinNameSpaceArray *result = newMinNameSpaceArray(); + int save = PROTECT(result); + + for (Index i = 0; i < node->size; i++) { + MinExp *element = peeknMinNameSpaceArray(node, i); + MinExp *new_element = etaMinExp(element); + PROTECT(new_element); + changed = changed || (new_element != element); + pushMinNameSpaceArray(result, new_element); + } + + if (changed) { + UNPROTECT(save); + LEAVE(etaMinNameSpaceArray); + return result; + } + + UNPROTECT(save); + LEAVE(etaMinNameSpaceArray); + return node; +} \ No newline at end of file diff --git a/src/minlam_eta.h b/src/minlam_eta.h new file mode 100644 index 00000000..68821277 --- /dev/null +++ b/src/minlam_eta.h @@ -0,0 +1,25 @@ +#ifndef cekf_minlam_eta_h +#define cekf_minlam_eta_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "minlam.h" + +MinExp *etaMinExp(MinExp *node); + +#endif diff --git a/src/minlam_fold.c b/src/minlam_fold.c new file mode 100644 index 00000000..a1118865 --- /dev/null +++ b/src/minlam_fold.c @@ -0,0 +1,559 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "memory.h" +#include "minlam.h" + +#include "minlam_fold.h" +#include "minlam_simplify.h" + +#ifdef DEBUG_MINLAM_FOLD +#include "debugging_on.h" +#else +#include "debugging_off.h" +#endif + +static MinLam *foldMinLam(MinLam *node); +static MinExprList *foldMinExprList(MinExprList *node); +static MinPrimApp *foldMinPrimApp(MinPrimApp *node); +static MinApply *foldMinApply(MinApply *node); +static MinLookUp *foldMinLookUp(MinLookUp *node); +static MinIff *foldMinIff(MinIff *node); +static MinCond *foldMinCond(MinCond *node); +static MinIntCondCases *foldMinIntCondCases(MinIntCondCases *node); +static MinCharCondCases *foldMinCharCondCases(MinCharCondCases *node); +static MinMatch *foldMinMatch(MinMatch *node); +static MinMatchList *foldMinMatchList(MinMatchList *node); +static MinIntList *foldMinIntList(MinIntList *node); +static MinLetRec *foldMinLetRec(MinLetRec *node); +static MinBindings *foldMinBindings(MinBindings *node); +static MinAmb *foldMinAmb(MinAmb *node); +static MinCondCases *foldMinCondCases(MinCondCases *node); +static MinNameSpaceArray *foldMinNameSpaceArray(MinNameSpaceArray *node); + +static bool primOpIsArithmetic(MinPrimOp op) { + switch (op) { + case MINPRIMOP_TYPE_ADD: + case MINPRIMOP_TYPE_SUB: + case MINPRIMOP_TYPE_MUL: + case MINPRIMOP_TYPE_DIV: + case MINPRIMOP_TYPE_MOD: + case MINPRIMOP_TYPE_POW: + return true; + default: + return false; + } +} + +static MinLam *foldMinLam(MinLam *node) { + if (node == NULL) + return NULL; + + MinExp *new_exp = foldMinExp(node->exp); + if (new_exp != node->exp) + return newMinLam(CPI(node), node->args, new_exp); + + return node; +} + +static MinExprList *foldMinExprList(MinExprList *node) { + if (node == NULL) + return NULL; + + MinExp *new_exp = foldMinExp(node->exp); + int save = PROTECT(new_exp); + MinExprList *new_next = foldMinExprList(node->next); + PROTECT(new_next); + + if (new_exp != node->exp || new_next != node->next) { + MinExprList *result = newMinExprList(CPI(node), new_exp, new_next); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinPrimApp *foldMinPrimApp(MinPrimApp *node) { + if (node == NULL) + return NULL; + + MinExp *new_exp1 = foldMinExp(node->exp1); + int save = PROTECT(new_exp1); + MinExp *new_exp2 = foldMinExp(node->exp2); + PROTECT(new_exp2); + + if (new_exp1 != node->exp1 || new_exp2 != node->exp2) { + MinPrimApp *result = + newMinPrimApp(CPI(node), node->type, new_exp1, new_exp2); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinApply *foldMinApply(MinApply *node) { + if (node == NULL) + return NULL; + + MinExp *new_function = foldMinExp(node->function); + int save = PROTECT(new_function); + MinExprList *new_args = foldMinExprList(node->args); + PROTECT(new_args); + + if (new_function != node->function || new_args != node->args) { + MinApply *result = newMinApply(CPI(node), new_function, new_args); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinLookUp *foldMinLookUp(MinLookUp *node) { + if (node == NULL) + return NULL; + + MinExp *new_exp = foldMinExp(node->exp); + if (new_exp != node->exp) + return newMinLookUp(CPI(node), node->nsId, new_exp); + + return node; +} + +static MinIff *foldMinIff(MinIff *node) { + if (node == NULL) + return NULL; + + MinExp *new_condition = foldMinExp(node->condition); + int save = PROTECT(new_condition); + MinExp *new_consequent = foldMinExp(node->consequent); + PROTECT(new_consequent); + MinExp *new_alternative = foldMinExp(node->alternative); + PROTECT(new_alternative); + + if (new_condition != node->condition || + new_consequent != node->consequent || + new_alternative != node->alternative) { + MinIff *result = newMinIff(CPI(node), new_condition, new_consequent, + new_alternative); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinCond *foldMinCond(MinCond *node) { + if (node == NULL) + return NULL; + + MinExp *new_value = foldMinExp(node->value); + int save = PROTECT(new_value); + MinCondCases *new_cases = foldMinCondCases(node->cases); + PROTECT(new_cases); + + if (new_value != node->value || new_cases != node->cases) { + MinCond *result = newMinCond(CPI(node), new_value, new_cases); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinIntCondCases *foldMinIntCondCases(MinIntCondCases *node) { + if (node == NULL) + return NULL; + + MinExp *new_body = foldMinExp(node->body); + int save = PROTECT(new_body); + MinIntCondCases *new_next = foldMinIntCondCases(node->next); + PROTECT(new_next); + + if (new_body != node->body || new_next != node->next) { + MinIntCondCases *result = + newMinIntCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinCharCondCases *foldMinCharCondCases(MinCharCondCases *node) { + if (node == NULL) + return NULL; + + MinExp *new_body = foldMinExp(node->body); + int save = PROTECT(new_body); + MinCharCondCases *new_next = foldMinCharCondCases(node->next); + PROTECT(new_next); + + if (new_body != node->body || new_next != node->next) { + MinCharCondCases *result = + newMinCharCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinMatch *foldMinMatch(MinMatch *node) { + if (node == NULL) + return NULL; + + MinExp *new_index = foldMinExp(node->index); + int save = PROTECT(new_index); + MinMatchList *new_cases = foldMinMatchList(node->cases); + PROTECT(new_cases); + + if (new_index != node->index || new_cases != node->cases) { + MinMatch *result = newMinMatch(CPI(node), new_index, new_cases); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinMatchList *foldMinMatchList(MinMatchList *node) { + if (node == NULL) + return NULL; + + MinIntList *new_matches = foldMinIntList(node->matches); + int save = PROTECT(new_matches); + MinExp *new_body = foldMinExp(node->body); + PROTECT(new_body); + MinMatchList *new_next = foldMinMatchList(node->next); + PROTECT(new_next); + + if (new_matches != node->matches || new_body != node->body || + new_next != node->next) { + MinMatchList *result = + newMinMatchList(CPI(node), new_matches, new_body, new_next); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinIntList *foldMinIntList(MinIntList *node) { + if (node == NULL) + return NULL; + + MinIntList *new_next = foldMinIntList(node->next); + if (new_next != node->next) + return newMinIntList(CPI(node), node->item, new_next); + + return node; +} + +static MinLetRec *foldMinLetRec(MinLetRec *node) { + if (node == NULL) + return NULL; + + MinBindings *new_bindings = foldMinBindings(node->bindings); + int save = PROTECT(new_bindings); + MinExp *new_body = foldMinExp(node->body); + PROTECT(new_body); + + if (new_bindings != node->bindings || new_body != node->body) { + MinLetRec *result = newMinLetRec(CPI(node), new_bindings, new_body); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinBindings *foldMinBindings(MinBindings *node) { + if (node == NULL) + return NULL; + + MinExp *new_val = foldMinExp(node->val); + int save = PROTECT(new_val); + MinBindings *new_next = foldMinBindings(node->next); + PROTECT(new_next); + + if (new_val != node->val || new_next != node->next) { + MinBindings *result = + newMinBindings(CPI(node), node->var, new_val, new_next); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +static MinAmb *foldMinAmb(MinAmb *node) { + if (node == NULL) + return NULL; + + MinExp *new_left = foldMinExp(node->left); + int save = PROTECT(new_left); + MinExp *new_right = foldMinExp(node->right); + PROTECT(new_right); + + if (new_left != node->left || new_right != node->right) { + MinAmb *result = newMinAmb(CPI(node), new_left, new_right); + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} + +MinExp *foldMinExp(MinExp *node) { + if (node == NULL) + return NULL; + + int save = PROTECT(NULL); + MinExp *result = node; + + switch (node->type) { + case MINEXP_TYPE_AMB: { + MinAmb *variant = getMinExp_Amb(node); + MinAmb *new_variant = foldMinAmb(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Amb(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_APPLY: { + MinApply *variant = getMinExp_Apply(node); + MinApply *new_variant = foldMinApply(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Apply(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_ARGS: { + // args is a compatibility node for the alternative normalize_2 path + // and is not a valid expression in the main MinExp pipeline. + cant_happen("MINEXP_TYPE_ARGS should not appear in foldMinExp"); + break; + } + case MINEXP_TYPE_BACK: + case MINEXP_TYPE_BIGINTEGER: + case MINEXP_TYPE_CHARACTER: + case MINEXP_TYPE_ENV: + case MINEXP_TYPE_ERROR: + case MINEXP_TYPE_STDINT: + case MINEXP_TYPE_VAR: + break; + case MINEXP_TYPE_BINDINGS: { + MinBindings *variant = getMinExp_Bindings(node); + MinBindings *new_variant = foldMinBindings(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Bindings(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_CALLCC: { + MinExp *variant = getMinExp_CallCC(node); + MinExp *new_variant = foldMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_CallCC(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_COND: { + MinCond *variant = getMinExp_Cond(node); + MinCond *new_variant = foldMinCond(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cond(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_IFF: { + MinIff *variant = getMinExp_Iff(node); + MinIff *new_variant = foldMinIff(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Iff(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LAM: { + MinLam *variant = getMinExp_Lam(node); + MinLam *new_variant = foldMinLam(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Lam(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LETREC: { + MinLetRec *variant = getMinExp_LetRec(node); + MinLetRec *new_variant = foldMinLetRec(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LetRec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LOOKUP: { + MinLookUp *variant = getMinExp_LookUp(node); + MinLookUp *new_variant = foldMinLookUp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LookUp(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MAKEVEC: { + MinExprList *variant = getMinExp_MakeVec(node); + MinExprList *new_variant = foldMinExprList(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_MakeVec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MATCH: { + MinMatch *variant = getMinExp_Match(node); + MinMatch *new_variant = foldMinMatch(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Match(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_NAMESPACES: { + MinNameSpaceArray *variant = getMinExp_NameSpaces(node); + MinNameSpaceArray *new_variant = foldMinNameSpaceArray(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_NameSpaces(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_PRIM: { + MinPrimApp *variant = getMinExp_Prim(node); + MinPrimApp *new_variant = foldMinPrimApp(variant); + MinExp *candidate = node; + if (new_variant != variant) { + PROTECT(new_variant); + candidate = newMinExp_Prim(CPI(node), new_variant); + } + MinPrimApp *candidatePrim = getMinExp_Prim(candidate); + bool hasArgsOperand = candidatePrim->exp1->type == MINEXP_TYPE_ARGS || + candidatePrim->exp2->type == MINEXP_TYPE_ARGS; + if (primOpIsArithmetic(candidatePrim->type) && !hasArgsOperand) { + result = simplifyMinExp(candidate); + } else { + result = candidate; + } + break; + } + case MINEXP_TYPE_SEQUENCE: { + MinExprList *variant = getMinExp_Sequence(node); + MinExprList *new_variant = foldMinExprList(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Sequence(CPI(node), new_variant); + } + break; + } + default: + cant_happen("unrecognized MinExp type %d", node->type); + } + + UNPROTECT(save); + return result; +} + +static MinCondCases *foldMinCondCases(MinCondCases *node) { + if (node == NULL) + return NULL; + + int save = PROTECT(NULL); + MinCondCases *result = node; + + switch (node->type) { + case MINCONDCASES_TYPE_INTEGERS: { + MinIntCondCases *variant = getMinCondCases_Integers(node); + MinIntCondCases *new_variant = foldMinIntCondCases(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Integers(CPI(node), new_variant); + } + break; + } + case MINCONDCASES_TYPE_CHARACTERS: { + MinCharCondCases *variant = getMinCondCases_Characters(node); + MinCharCondCases *new_variant = foldMinCharCondCases(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Characters(CPI(node), new_variant); + } + break; + } + default: + cant_happen("unrecognized MinCondCases type %d", node->type); + } + + UNPROTECT(save); + return result; +} + +static MinNameSpaceArray *foldMinNameSpaceArray(MinNameSpaceArray *node) { + if (node == NULL) + return NULL; + + bool changed = false; + MinNameSpaceArray *result = newMinNameSpaceArray(); + int save = PROTECT(result); + + for (Index i = 0; i < node->size; i++) { + MinExp *element = peeknMinNameSpaceArray(node, i); + MinExp *new_element = foldMinExp(element); + PROTECT(new_element); + changed = changed || (new_element != element); + pushMinNameSpaceArray(result, new_element); + } + + if (changed) { + UNPROTECT(save); + return result; + } + + UNPROTECT(save); + return node; +} diff --git a/src/minlam_fold.h b/src/minlam_fold.h new file mode 100644 index 00000000..967ffe0f --- /dev/null +++ b/src/minlam_fold.h @@ -0,0 +1,25 @@ +#ifndef cekf_minlam_fold_h +#define cekf_minlam_fold_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "minlam.h" + +MinExp *foldMinExp(MinExp *node); + +#endif diff --git a/src/minlam_helper.c b/src/minlam_helper.c new file mode 100644 index 00000000..d03805b1 --- /dev/null +++ b/src/minlam_helper.c @@ -0,0 +1,31 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "minlam_helper.h" + +SymbolList *minBindingsToSymbolList(MinBindings *bindings) { + if (bindings == NULL) { + return NULL; + } + + SymbolList *next = minBindingsToSymbolList(bindings->next); + int save = PROTECT(next); + SymbolList *this = newSymbolList(CPI(bindings), bindings->var, next); + UNPROTECT(save); + return this; +} \ No newline at end of file diff --git a/src/minlam_helper.h b/src/minlam_helper.h index b967e354..242b001b 100644 --- a/src/minlam_helper.h +++ b/src/minlam_helper.h @@ -19,5 +19,8 @@ */ #include "minlam.h" +#include "utils.h" + +SymbolList *minBindingsToSymbolList(MinBindings *bindings); #endif diff --git a/src/minlam_occurs.c b/src/minlam_occurs.c new file mode 100644 index 00000000..298541ac --- /dev/null +++ b/src/minlam_occurs.c @@ -0,0 +1,267 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + * + * Minimal AST after desugaring + * Generated from src/minlam.yaml by tools/generate.py + */ + +#include "minlam_occurs.h" +#include "memory.h" +#include "minlam.h" +#include "minlam_helper.h" +#include "utils_helper.h" + +#ifdef DEBUG_MINLAM_OCCURS +#include "debugging_on.h" +#else +#include "debugging_off.h" +#endif + +// Forward declarations +static bool occursMinLam(MinLam *node, SymbolSet *targets); +static bool occursMinExprList(MinExprList *node, SymbolSet *targets); +static bool occursMinPrimApp(MinPrimApp *node, SymbolSet *targets); +static bool occursMinApply(MinApply *node, SymbolSet *targets); +static bool occursMinIff(MinIff *node, SymbolSet *targets); +static bool occursMinCond(MinCond *node, SymbolSet *targets); +static bool occursMinIntCondCases(MinIntCondCases *node, SymbolSet *targets); +static bool occursMinCharCondCases(MinCharCondCases *node, SymbolSet *targets); +static bool occursMinMatch(MinMatch *node, SymbolSet *targets); +static bool occursMinMatchList(MinMatchList *node, SymbolSet *targets); +static bool occursMinLetRec(MinLetRec *node, SymbolSet *targets); +static bool occursMinBindings(MinBindings *node, SymbolSet *targets); +static bool occursMinAmb(MinAmb *node, SymbolSet *targets); +static bool occursMinCondCases(MinCondCases *node, SymbolSet *targets); +static bool occursMinNameSpaceArray(MinNameSpaceArray *node, + SymbolSet *targets); + +// Visitor implementations + +static bool occursMinLam(MinLam *node, SymbolSet *targets) { + if (node == NULL) { + return false; + } + + SymbolSet *remaining = symbolsNotInList(node->args, targets); + int save = PROTECT(remaining); + if (countSymbolSet(remaining) == 0) { + UNPROTECT(save); + return false; + } + + bool res = occursMinExp(node->exp, remaining); + UNPROTECT(save); + return res; +} + +static bool occursMinExprList(MinExprList *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->exp, targets) || + occursMinExprList(node->next, targets)); +} + +static bool occursMinPrimApp(MinPrimApp *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->exp1, targets) || + occursMinExp(node->exp2, targets)); +} + +static bool occursMinApply(MinApply *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->function, targets) || + occursMinExprList(node->args, targets)); +} + +static bool occursMinIff(MinIff *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->condition, targets) || + occursMinExp(node->consequent, targets) || + occursMinExp(node->alternative, targets)); +} + +static bool occursMinCond(MinCond *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->value, targets) || + occursMinCondCases(node->cases, targets)); +} + +static bool occursMinIntCondCases(MinIntCondCases *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->body, targets) || + occursMinIntCondCases(node->next, targets)); +} + +static bool occursMinCharCondCases(MinCharCondCases *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->body, targets) || + occursMinCharCondCases(node->next, targets)); +} + +static bool occursMinMatch(MinMatch *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->index, targets) || + occursMinMatchList(node->cases, targets)); +} + +static bool occursMinMatchList(MinMatchList *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->body, targets) || + occursMinMatchList(node->next, targets)); +} + +static bool occursMinLetRec(MinLetRec *node, SymbolSet *targets) { + if (node == NULL) { + return false; + } + + SymbolList *vars = minBindingsToSymbolList(node->bindings); + int save = PROTECT(vars); + SymbolSet *remaining = symbolsNotInList(vars, targets); + PROTECT(remaining); + if (countSymbolSet(remaining) == 0) { + UNPROTECT(save); + return false; + } + bool res = occursMinBindings(node->bindings, remaining) || + occursMinExp(node->body, remaining); + UNPROTECT(save); + return res; +} + +static bool occursMinBindings(MinBindings *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->val, targets) || + occursMinBindings(node->next, targets)); +} + +static bool occursMinAmb(MinAmb *node, SymbolSet *targets) { + return node != NULL && (occursMinExp(node->left, targets) || + occursMinExp(node->right, targets)); +} + +/** + * Main entry point for MinExp visitor + * + * Return true if any symbol in targets occurs free in node. + */ +bool occursMinExp(MinExp *node, SymbolSet *targets) { + if (node == NULL) { + return false; + } + switch (node->type) { + case MINEXP_TYPE_AMB: { + MinAmb *variant = getMinExp_Amb(node); + return occursMinAmb(variant, targets); + } + case MINEXP_TYPE_APPLY: { + MinApply *variant = getMinExp_Apply(node); + return occursMinApply(variant, targets); + } + case MINEXP_TYPE_BACK: { + return false; + } + case MINEXP_TYPE_BIGINTEGER: { + return false; + break; + } + case MINEXP_TYPE_CALLCC: { + MinExp *variant = getMinExp_CallCC(node); + return occursMinExp(variant, targets); + } + case MINEXP_TYPE_CHARACTER: { + return false; + } + case MINEXP_TYPE_COND: { + MinCond *variant = getMinExp_Cond(node); + return occursMinCond(variant, targets); + } + case MINEXP_TYPE_ENV: { + return false; + } + case MINEXP_TYPE_ERROR: { + return false; + } + case MINEXP_TYPE_IFF: { + MinIff *variant = getMinExp_Iff(node); + return occursMinIff(variant, targets); + } + case MINEXP_TYPE_LAM: { + MinLam *variant = getMinExp_Lam(node); + return occursMinLam(variant, targets); + } + case MINEXP_TYPE_LETREC: { + MinLetRec *variant = getMinExp_LetRec(node); + return occursMinLetRec(variant, targets); + } + case MINEXP_TYPE_LOOKUP: { + return false; + } + case MINEXP_TYPE_MAKEVEC: { + MinExprList *variant = getMinExp_MakeVec(node); + return occursMinExprList(variant, targets); + } + case MINEXP_TYPE_MATCH: { + MinMatch *variant = getMinExp_Match(node); + return occursMinMatch(variant, targets); + } + case MINEXP_TYPE_NAMESPACES: { + MinNameSpaceArray *variant = getMinExp_NameSpaces(node); + return occursMinNameSpaceArray(variant, targets); + } + case MINEXP_TYPE_PRIM: { + MinPrimApp *variant = getMinExp_Prim(node); + return occursMinPrimApp(variant, targets); + } + case MINEXP_TYPE_SEQUENCE: { + MinExprList *variant = getMinExp_Sequence(node); + return occursMinExprList(variant, targets); + } + case MINEXP_TYPE_STDINT: { + return false; + } + case MINEXP_TYPE_VAR: { + HashSymbol *var = getMinExp_Var(node); + return getSymbolSet(targets, var); + } + default: + cant_happen("unrecognized MinExp type %d", node->type); + } +} + +static bool occursMinCondCases(MinCondCases *node, SymbolSet *targets) { + if (node == NULL) { + return false; + } + + switch (node->type) { + case MINCONDCASES_TYPE_INTEGERS: { + MinIntCondCases *variant = getMinCondCases_Integers(node); + return occursMinIntCondCases(variant, targets); + } + case MINCONDCASES_TYPE_CHARACTERS: { + MinCharCondCases *variant = getMinCondCases_Characters(node); + return occursMinCharCondCases(variant, targets); + } + default: + cant_happen("unrecognized MinCondCases type %d", node->type); + } +} + +static bool occursMinNameSpaceArray(MinNameSpaceArray *node, + SymbolSet *targets) { + if (node == NULL) { + return false; + } + + for (Index i = 0; i < node->size; i++) { + struct MinExp *element = peeknMinNameSpaceArray(node, i); + if (occursMinExp(element, targets)) { + return true; + } + } + return false; +} \ No newline at end of file diff --git a/src/minlam_occurs.h b/src/minlam_occurs.h new file mode 100644 index 00000000..cb28ddd0 --- /dev/null +++ b/src/minlam_occurs.h @@ -0,0 +1,26 @@ +#ifndef cekf_minlam_occurs_h +#define cekf_minlam_occurs_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "minlam.h" +#include + +bool occursMinExp(MinExp *, SymbolSet *); + +#endif diff --git a/src/minlam_simplify.c b/src/minlam_simplify.c new file mode 100644 index 00000000..9ad6e747 --- /dev/null +++ b/src/minlam_simplify.c @@ -0,0 +1,996 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "minlam_simplify.h" + +#include "arithmetic.h" +#include "term_helper.h" + +static inline bool isTermNum(Term *term) { + return term != NULL && term->type == TERM_TYPE_NUM; +} + +static inline Value termNumValue(Term *term) { + return getTerm_Num(term)->value; +} + +static inline bool isZeroValue(Value value) { + return ncmp(value, value_Stdint(0)) == CMP_EQ; +} + +static inline bool isOneValue(Value value) { + return ncmp(value, value_Stdint(1)) == CMP_EQ; +} + +static inline bool isZeroTerm(Term *term) { + return isTermNum(term) && isZeroValue(termNumValue(term)); +} + +static inline bool isOneTerm(Term *term) { + return isTermNum(term) && isOneValue(termNumValue(term)); +} + +static inline Term *Num(ParserInfo parserInfo, Value value) { + Term *result = makeTerm_Num(parserInfo, value); + PROTECT(result); + return result; +} + +static inline Term *NumInt(ParserInfo parserInfo, int n) { + return Num(parserInfo, value_Stdint(n)); +} + +static inline Term *Add(ParserInfo parserInfo, Term *left, Term *right) { + Term *result = makeTerm_Add(parserInfo, left, right); + PROTECT(result); + return result; +} + +static inline Term *Sub(ParserInfo parserInfo, Term *left, Term *right) { + Term *result = makeTerm_Sub(parserInfo, left, right); + PROTECT(result); + return result; +} + +static inline Term *Mul(ParserInfo parserInfo, Term *left, Term *right) { + Term *result = makeTerm_Mul(parserInfo, left, right); + PROTECT(result); + return result; +} + +static inline Term *Div(ParserInfo parserInfo, Term *left, Term *right) { + Term *result = makeTerm_Div(parserInfo, left, right); + PROTECT(result); + return result; +} + +static inline Term *Pow(ParserInfo parserInfo, Term *left, Term *right) { + Term *result = makeTerm_Pow(parserInfo, left, right); + PROTECT(result); + return result; +} + +static inline Term *Mod(ParserInfo parserInfo, Term *left, Term *right) { + Term *result = makeTerm_Mod(parserInfo, left, right); + PROTECT(result); + return result; +} + +static inline bool isSubTerm(Term *term) { + return term != NULL && term->type == TERM_TYPE_SUB; +} + +static inline bool isAddTerm(Term *term) { + return term != NULL && term->type == TERM_TYPE_ADD; +} + +static inline bool isDivTerm(Term *term) { + return term != NULL && term->type == TERM_TYPE_DIV; +} + +static inline bool isMulTerm(Term *term) { + return term != NULL && term->type == TERM_TYPE_MUL; +} + +static inline bool isPowTerm(Term *term) { + return term != NULL && term->type == TERM_TYPE_POW; +} + +static inline bool isModTerm(Term *term) { + return term != NULL && term->type == TERM_TYPE_MOD; +} + +static bool matchSubZero(Term *term, Term **inner) { + if (!isSubTerm(term)) + return false; + + TermOp *sub = getTerm_Sub(term); + if (!isZeroTerm(sub->left)) + return false; + + *inner = sub->right; + return true; +} + +static bool matchAddNumOther(Term *term, Value *num, Term **other) { + if (!isAddTerm(term)) + return false; + + TermOp *add = getTerm_Add(term); + if (isTermNum(add->left)) { + *num = termNumValue(add->left); + *other = add->right; + return true; + } + if (isTermNum(add->right)) { + *num = termNumValue(add->right); + *other = add->left; + return true; + } + return false; +} + +static bool matchSubNumOther(Term *term, Value *num, Term **other) { + if (!isSubTerm(term)) + return false; + + TermOp *sub = getTerm_Sub(term); + if (!isTermNum(sub->left)) + return false; + + *num = termNumValue(sub->left); + *other = sub->right; + return true; +} + +static bool matchSubOtherNum(Term *term, Term **other, Value *num) { + if (!isSubTerm(term)) + return false; + + TermOp *sub = getTerm_Sub(term); + if (!isTermNum(sub->right)) + return false; + + *other = sub->left; + *num = termNumValue(sub->right); + return true; +} + +static bool matchMulNumOther(Term *term, Value *num, Term **other) { + if (!isMulTerm(term)) + return false; + + TermOp *mul = getTerm_Mul(term); + if (isTermNum(mul->left)) { + *num = termNumValue(mul->left); + *other = mul->right; + return true; + } + if (isTermNum(mul->right)) { + *num = termNumValue(mul->right); + *other = mul->left; + return true; + } + return false; +} + +static bool matchDivNumOther(Term *term, Value *num, Term **other) { + if (!isDivTerm(term)) + return false; + + TermOp *div = getTerm_Div(term); + if (!isTermNum(div->left)) + return false; + + *num = termNumValue(div->left); + *other = div->right; + return true; +} + +static bool matchDivOtherNum(Term *term, Term **other, Value *num) { + if (!isDivTerm(term)) + return false; + + TermOp *div = getTerm_Div(term); + if (!isTermNum(div->right)) + return false; + + *other = div->left; + *num = termNumValue(div->right); + return true; +} + +static bool matchDivTerms(Term *term, Term **numerator, Term **denominator) { + if (!isDivTerm(term)) + return false; + + TermOp *div = getTerm_Div(term); + *numerator = div->left; + *denominator = div->right; + return true; +} + +static bool matchMulWithFactor(Term *term, Term *factor, Term **other) { + if (!isMulTerm(term)) + return false; + + TermOp *mul = getTerm_Mul(term); + if (eqTerm(mul->left, factor)) { + *other = mul->right; + return true; + } + if (eqTerm(mul->right, factor)) { + *other = mul->left; + return true; + } + return false; +} + +typedef Value (*NumericOpFn)(Value, Value); +typedef Term *(*BuildTermOpFn)(ParserInfo, Term *, Term *); +typedef TermOp *(*GetTermOpFn)(Term *); + +typedef struct BinaryOpSpec { + TermType op; + NumericOpFn numeric; + BuildTermOpFn build; + GetTermOpFn get; +} BinaryOpSpec; + +static const BinaryOpSpec *lookupBinaryOpSpec(TermType op) { + static const BinaryOpSpec specs[] = { + {TERM_TYPE_ADD, nadd, Add, getTerm_Add}, + {TERM_TYPE_SUB, nsub, Sub, getTerm_Sub}, + {TERM_TYPE_MUL, nmul, Mul, getTerm_Mul}, + {TERM_TYPE_DIV, ndiv, Div, getTerm_Div}, + {TERM_TYPE_MOD, nmod, Mod, getTerm_Mod}, + {TERM_TYPE_POW, npow, Pow, getTerm_Pow}, + }; + + for (size_t i = 0; i < sizeof(specs) / sizeof(specs[0]); i++) { + if (specs[i].op == op) + return &specs[i]; + } + return NULL; +} + +static Term *makeNumericOpResult(ParserInfo parserInfo, TermType op, Value left, + Value right) { + const BinaryOpSpec *spec = lookupBinaryOpSpec(op); + if (spec == NULL) { + cant_happen("unsupported term op %d in makeNumericOpResult", op); + } + return Num(parserInfo, spec->numeric(left, right)); +} + +static Term *simplifyTerm(Term *term); + +#define RETURN_MATCH(expr) \ + do { \ + *result = (expr); \ + UNPROTECT(save); \ + return true; \ + } while (0) + +#define RETURN_NO_MATCH() \ + do { \ + UNPROTECT(save); \ + return false; \ + } while (0) + +static bool tryConstantFold(Term *term, TermType op, Term *left, Term *right, + Term **result) { + if (isTermNum(left) && isTermNum(right)) { + *result = makeNumericOpResult(CPI(term), op, termNumValue(left), + termNumValue(right)); + return true; + } + return false; +} + +static bool tryAddIdentity(Term *term, Term *left, Term *right, Term **result) { + int save = PROTECT(NULL); + Term *inner = NULL; + Term *leftNum = NULL; + Term *leftDen = NULL; + Term *rightNum = NULL; + Term *rightDen = NULL; + Value a; + Value b; + Value c; + Term *x = NULL; + Term *y = NULL; + + if (isZeroTerm(left)) { + RETURN_MATCH(right); + } + if (isZeroTerm(right)) { + RETURN_MATCH(left); + } + + if (matchSubZero(right, &inner) && eqTerm(left, inner)) { + RETURN_MATCH(NumInt(CPI(left), 0)); + } + + if (matchSubZero(left, &inner) && eqTerm(right, inner)) { + RETURN_MATCH(NumInt(CPI(right), 0)); + } + + if (eqTerm(left, right)) { + Term *two = NumInt(CPI(left), 2); + RETURN_MATCH(Mul(CPI(left), two, left)); + } + + if (matchDivTerms(left, &leftNum, &leftDen) && + matchDivTerms(right, &rightNum, &rightDen) && + eqTerm(leftDen, rightDen)) { + Term *numerator = Add(CPI(term), leftNum, rightNum); + RETURN_MATCH(Div(CPI(term), numerator, leftDen)); + } + + if (isTermNum(left)) { + a = termNumValue(left); + + if (matchAddNumOther(right, &b, &x)) { + Term *sum = Num(CPI(term), nadd(a, b)); + RETURN_MATCH(Add(CPI(term), sum, x)); + } + + if (matchSubNumOther(right, &b, &x)) { + Term *sum = Num(CPI(term), nadd(a, b)); + RETURN_MATCH(Sub(CPI(term), sum, x)); + } + + if (matchSubOtherNum(right, &x, &b)) { + Term *diff = Num(CPI(term), nsub(a, b)); + RETURN_MATCH(Add(CPI(term), diff, x)); + } + } + + if (isTermNum(right)) { + a = termNumValue(right); + + if (matchAddNumOther(left, &b, &x)) { + Term *sum = Num(CPI(term), nadd(a, b)); + RETURN_MATCH(Add(CPI(term), sum, x)); + } + + if (matchSubNumOther(left, &b, &x)) { + Term *sum = Num(CPI(term), nadd(a, b)); + RETURN_MATCH(Sub(CPI(term), sum, x)); + } + + if (matchSubOtherNum(left, &x, &b)) { + Term *diff = Num(CPI(term), nsub(a, b)); + RETURN_MATCH(Add(CPI(term), diff, x)); + } + } + + if (matchAddNumOther(left, &a, &x) && matchAddNumOther(right, &b, &y)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), sum, tail)); + } + + if (matchAddNumOther(left, &a, &x) && matchSubNumOther(right, &b, &y)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *tail = Sub(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), sum, tail)); + } + + if (matchSubNumOther(left, &a, &x) && matchAddNumOther(right, &b, &y)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *tail = Sub(CPI(term), y, x); + RETURN_MATCH(Add(CPI(term), sum, tail)); + } + + if (matchAddNumOther(left, &a, &x) && matchSubOtherNum(right, &y, &b)) { + Term *diff = Num(CPI(term), nsub(a, b)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), diff, tail)); + } + + if (matchSubOtherNum(left, &x, &a) && matchAddNumOther(right, &b, &y)) { + Term *diff = Num(CPI(term), nsub(b, a)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), diff, tail)); + } + + if (matchSubNumOther(left, &a, &x) && matchSubNumOther(right, &b, &y)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Sub(CPI(term), sum, tail)); + } + + if (matchSubOtherNum(left, &x, &a) && matchSubNumOther(right, &b, &y)) { + Term *diff = Num(CPI(term), nsub(b, a)); + Term *tail = Sub(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), diff, tail)); + } + + if (matchSubNumOther(left, &a, &x) && matchSubOtherNum(right, &y, &b)) { + Term *diff = Num(CPI(term), nsub(a, b)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), diff, tail)); + } + + if (matchSubOtherNum(left, &x, &a) && matchSubOtherNum(right, &y, &b)) { + c = nadd(a, b); + Term *sum = Num(CPI(term), c); + Term *head = Add(CPI(term), x, y); + RETURN_MATCH(Sub(CPI(term), head, sum)); + } + + RETURN_NO_MATCH(); +} + +static bool trySubIdentity(Term *term, Term *left, Term *right, Term **result) { + int save = PROTECT(NULL); + Term *inner = NULL; + Term *leftNum = NULL; + Term *leftDen = NULL; + Term *rightNum = NULL; + Term *rightDen = NULL; + Value a; + Value b; + Term *x = NULL; + Term *y = NULL; + + if (isZeroTerm(right)) { + RETURN_MATCH(left); + } + if (eqTerm(left, right)) { + RETURN_MATCH(NumInt(CPI(term), 0)); + } + + if (isZeroTerm(left) && matchSubZero(right, &inner)) { + RETURN_MATCH(inner); + } + + if (matchDivTerms(left, &leftNum, &leftDen) && + matchDivTerms(right, &rightNum, &rightDen) && + eqTerm(leftDen, rightDen)) { + Term *numerator = Sub(CPI(term), leftNum, rightNum); + RETURN_MATCH(Div(CPI(term), numerator, leftDen)); + } + + if (isTermNum(left)) { + a = termNumValue(left); + + if (matchAddNumOther(right, &b, &x)) { + Term *diff = Num(CPI(term), nsub(a, b)); + RETURN_MATCH(Sub(CPI(term), diff, x)); + } + + if (matchSubNumOther(right, &b, &x)) { + Term *diff = Num(CPI(term), nsub(a, b)); + RETURN_MATCH(Add(CPI(term), diff, x)); + } + + if (matchSubOtherNum(right, &x, &b)) { + Term *sum = Num(CPI(term), nadd(a, b)); + RETURN_MATCH(Sub(CPI(term), sum, x)); + } + } + + if (isTermNum(right)) { + b = termNumValue(right); + + if (matchAddNumOther(left, &a, &x)) { + Term *diff = Num(CPI(term), nsub(a, b)); + RETURN_MATCH(Add(CPI(term), diff, x)); + } + + if (matchSubNumOther(left, &a, &x)) { + Term *diff = Num(CPI(term), nsub(a, b)); + RETURN_MATCH(Sub(CPI(term), diff, x)); + } + + if (matchSubOtherNum(left, &x, &a)) { + Term *sum = Num(CPI(term), nadd(a, b)); + RETURN_MATCH(Sub(CPI(term), x, sum)); + } + } + + if (matchAddNumOther(left, &a, &x) && matchAddNumOther(right, &b, &y)) { + Term *diff = Num(CPI(term), nsub(a, b)); + Term *tail = Sub(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), diff, tail)); + } + + if (matchSubNumOther(left, &a, &x) && matchSubNumOther(right, &b, &y)) { + Term *diff = Num(CPI(term), nsub(a, b)); + Term *tail = Sub(CPI(term), x, y); + RETURN_MATCH(Sub(CPI(term), diff, tail)); + } + + if (matchSubOtherNum(left, &x, &a) && matchSubOtherNum(right, &y, &b)) { + Term *diff = Num(CPI(term), nsub(b, a)); + Term *tail = Sub(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), diff, tail)); + } + + if (matchSubNumOther(left, &a, &x) && matchAddNumOther(right, &b, &y)) { + Term *diff = Num(CPI(term), nsub(a, b)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Sub(CPI(term), diff, tail)); + } + + if (matchSubOtherNum(left, &x, &a) && matchAddNumOther(right, &b, &y)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *head = Sub(CPI(term), x, sum); + RETURN_MATCH(Sub(CPI(term), head, y)); + } + + if (matchAddNumOther(left, &a, &x) && matchSubNumOther(right, &b, &y)) { + Term *diff = Num(CPI(term), nsub(a, b)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), diff, tail)); + } + + if (matchAddNumOther(left, &a, &x) && matchSubOtherNum(right, &y, &b)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *tail = Sub(CPI(term), x, y); + RETURN_MATCH(Add(CPI(term), sum, tail)); + } + + if (matchSubNumOther(left, &a, &x) && matchSubOtherNum(right, &y, &b)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *tail = Add(CPI(term), x, y); + RETURN_MATCH(Sub(CPI(term), sum, tail)); + } + + if (matchSubOtherNum(left, &x, &a) && matchSubNumOther(right, &b, &y)) { + Term *sum = Num(CPI(term), nadd(a, b)); + Term *head = Sub(CPI(term), x, sum); + RETURN_MATCH(Add(CPI(term), head, y)); + } + + RETURN_NO_MATCH(); +} + +static bool tryMulIdentity(Term *term, Term *left, Term *right, Term **result) { + int save = PROTECT(NULL); + TermOp *div = NULL; + TermOp *pow = NULL; + Value a; + Value b; + Term *x = NULL; + Term *y = NULL; + Term *numA = NULL; + + if (isZeroTerm(left) || isZeroTerm(right)) { + RETURN_MATCH(NumInt(CPI(term), 0)); + } + if (isOneTerm(left)) { + RETURN_MATCH(right); + } + if (isOneTerm(right)) { + RETURN_MATCH(left); + } + + if (eqTerm(left, right)) { + Term *two = NumInt(CPI(term), 2); + RETURN_MATCH(Pow(CPI(term), left, two)); + } + + if (isDivTerm(right)) { + div = getTerm_Div(right); + if (eqTerm(left, div->right)) { + RETURN_MATCH(div->left); + } + } + + if (isDivTerm(left)) { + div = getTerm_Div(left); + if (eqTerm(right, div->right)) { + RETURN_MATCH(div->left); + } + } + + if (isPowTerm(right)) { + pow = getTerm_Pow(right); + if (eqTerm(left, pow->left)) { + Term *one = NumInt(CPI(term), 1); + Term *exp = Add(CPI(term), pow->right, one); + RETURN_MATCH(Pow(CPI(term), left, exp)); + } + } + + if (isPowTerm(left)) { + pow = getTerm_Pow(left); + if (eqTerm(right, pow->left)) { + Term *one = NumInt(CPI(term), 1); + Term *exp = Add(CPI(term), pow->right, one); + RETURN_MATCH(Pow(CPI(term), right, exp)); + } + } + + if (isPowTerm(left) && isPowTerm(right)) { + TermOp *lp = getTerm_Pow(left); + TermOp *rp = getTerm_Pow(right); + if (eqTerm(lp->left, rp->left)) { + Term *exp = Add(CPI(term), lp->right, rp->right); + RETURN_MATCH(Pow(CPI(term), lp->left, exp)); + } + } + + if (matchDivOtherNum(left, &x, &a) && matchDivOtherNum(right, &y, &b)) { + Term *num = Mul(CPI(term), x, y); + Term *den = Num(CPI(term), nmul(a, b)); + RETURN_MATCH(Div(CPI(term), num, den)); + } + + if (matchDivNumOther(left, &a, &x) && matchDivNumOther(right, &b, &y)) { + Term *num = Num(CPI(term), nmul(a, b)); + Term *den = Mul(CPI(term), x, y); + RETURN_MATCH(Div(CPI(term), num, den)); + } + + if (isTermNum(left)) { + a = termNumValue(left); + numA = Num(CPI(term), a); + + if (matchDivNumOther(right, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + RETURN_MATCH(Div(CPI(term), ab, x)); + } + + if (matchDivOtherNum(right, &x, &b)) { + Term *q = Num(CPI(term), ndiv(a, b)); + RETURN_MATCH(Mul(CPI(term), q, x)); + } + + if (matchMulNumOther(right, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + RETURN_MATCH(Mul(CPI(term), ab, x)); + } + + if (matchAddNumOther(right, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + Term *ax = Mul(CPI(term), numA, x); + RETURN_MATCH(Add(CPI(term), ab, ax)); + } + + if (matchSubNumOther(right, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + Term *ax = Mul(CPI(term), numA, x); + RETURN_MATCH(Sub(CPI(term), ab, ax)); + } + + if (matchSubOtherNum(right, &x, &b)) { + Term *ab = Num(CPI(term), nmul(a, b)); + Term *ax = Mul(CPI(term), numA, x); + RETURN_MATCH(Sub(CPI(term), ax, ab)); + } + } + + if (isTermNum(right)) { + a = termNumValue(right); + numA = Num(CPI(term), a); + + if (matchDivNumOther(left, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + RETURN_MATCH(Div(CPI(term), ab, x)); + } + + if (matchDivOtherNum(left, &x, &b)) { + Term *q = Num(CPI(term), ndiv(a, b)); + RETURN_MATCH(Mul(CPI(term), q, x)); + } + + if (matchMulNumOther(left, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + RETURN_MATCH(Mul(CPI(term), ab, x)); + } + + if (matchAddNumOther(left, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + Term *ax = Mul(CPI(term), numA, x); + RETURN_MATCH(Add(CPI(term), ab, ax)); + } + + if (matchSubNumOther(left, &b, &x)) { + Term *ab = Num(CPI(term), nmul(a, b)); + Term *ax = Mul(CPI(term), numA, x); + RETURN_MATCH(Sub(CPI(term), ab, ax)); + } + + if (matchSubOtherNum(left, &x, &b)) { + Term *ab = Num(CPI(term), nmul(a, b)); + Term *ax = Mul(CPI(term), numA, x); + RETURN_MATCH(Sub(CPI(term), ax, ab)); + } + } + + RETURN_NO_MATCH(); +} + +static bool tryDivIdentity(Term *term, Term *left, Term *right, Term **result) { + int save = PROTECT(NULL); + TermOp *outer = NULL; + TermOp *lpow = NULL; + TermOp *rpow = NULL; + TermOp *leftMul = NULL; + TermOp *rightMul = NULL; + Value a; + Value b; + Term *x = NULL; + Term *y = NULL; + Term *divisor = NULL; + Term *other = NULL; + + if (isZeroTerm(left)) { + RETURN_MATCH(NumInt(CPI(term), 0)); + } + if (isOneTerm(right)) { + RETURN_MATCH(left); + } + if (eqTerm(left, right)) { + RETURN_MATCH(NumInt(CPI(term), 1)); + } + + if (isMulTerm(left) && isMulTerm(right)) { + leftMul = getTerm_Mul(left); + rightMul = getTerm_Mul(right); + + if (matchMulWithFactor(right, leftMul->left, &other)) { + RETURN_MATCH(Div(CPI(term), leftMul->right, other)); + } + if (matchMulWithFactor(right, leftMul->right, &other)) { + RETURN_MATCH(Div(CPI(term), leftMul->left, other)); + } + if (matchMulWithFactor(left, rightMul->left, &other)) { + RETURN_MATCH(Div(CPI(term), other, rightMul->right)); + } + if (matchMulWithFactor(left, rightMul->right, &other)) { + RETURN_MATCH(Div(CPI(term), other, rightMul->left)); + } + } + + if (matchDivOtherNum(left, &x, &a) && isTermNum(right)) { + b = termNumValue(right); + RETURN_MATCH(Div(CPI(term), x, Num(CPI(term), nmul(a, b)))); + } + + if (matchDivNumOther(left, &a, &x) && isTermNum(right)) { + b = termNumValue(right); + RETURN_MATCH(Div(CPI(term), Num(CPI(term), ndiv(a, b)), x)); + } + + if (matchDivOtherNum(left, &x, &a) && matchDivOtherNum(right, &y, &b)) { + Term *xy = Div(CPI(term), x, y); + Term *k = Num(CPI(term), ndiv(b, a)); + RETURN_MATCH(Mul(CPI(term), xy, k)); + } + + if (matchDivNumOther(left, &a, &x) && matchDivNumOther(right, &b, &y)) { + Term *k = Num(CPI(term), ndiv(a, b)); + Term *yx = Div(CPI(term), y, x); + RETURN_MATCH(Mul(CPI(term), k, yx)); + } + + if (isDivTerm(left)) { + outer = getTerm_Div(left); + Term *den = Mul(CPI(term), outer->right, right); + RETURN_MATCH(Div(CPI(term), outer->left, den)); + } + + if (isPowTerm(left)) { + lpow = getTerm_Pow(left); + if (eqTerm(lpow->left, right)) { + Term *one = NumInt(CPI(term), 1); + Term *exp = Sub(CPI(term), lpow->right, one); + RETURN_MATCH(Pow(CPI(term), lpow->left, exp)); + } + } + + if (isPowTerm(left) && isPowTerm(right)) { + lpow = getTerm_Pow(left); + rpow = getTerm_Pow(right); + if (eqTerm(lpow->left, rpow->left)) { + Term *exp = Sub(CPI(term), lpow->right, rpow->right); + RETURN_MATCH(Pow(CPI(term), lpow->left, exp)); + } + } + + if (isTermNum(left)) { + a = termNumValue(left); + + if (matchDivNumOther(right, &b, &x)) { + Term *q = Num(CPI(term), ndiv(a, b)); + RETURN_MATCH(Mul(CPI(term), q, x)); + } + + if (matchDivOtherNum(right, &x, &b)) { + Term *ab = Num(CPI(term), nmul(a, b)); + RETURN_MATCH(Div(CPI(term), ab, x)); + } + + if (matchMulNumOther(right, &b, &x)) { + Term *q = Num(CPI(term), ndiv(a, b)); + RETURN_MATCH(Div(CPI(term), q, x)); + } + } + + if (isTermNum(right)) { + b = termNumValue(right); + divisor = Num(CPI(term), b); + + if (matchMulNumOther(left, &a, &x)) { + Term *q = Num(CPI(term), ndiv(a, b)); + RETURN_MATCH(Mul(CPI(term), q, x)); + } + + if (matchAddNumOther(left, &a, &x)) { + Term *q = Num(CPI(term), ndiv(a, b)); + Term *xd = Div(CPI(term), x, divisor); + RETURN_MATCH(Add(CPI(term), q, xd)); + } + + if (matchSubNumOther(left, &a, &x)) { + Term *q = Num(CPI(term), ndiv(a, b)); + Term *xd = Div(CPI(term), x, divisor); + RETURN_MATCH(Sub(CPI(term), q, xd)); + } + + if (matchSubOtherNum(left, &x, &a)) { + Term *q = Num(CPI(term), ndiv(a, b)); + Term *xd = Div(CPI(term), x, divisor); + RETURN_MATCH(Sub(CPI(term), xd, q)); + } + } + + RETURN_NO_MATCH(); +} + +static bool tryModIdentity(Term *term, Term *left, Term *right, Term **result) { + int save = PROTECT(NULL); + TermOp *inner = NULL; + + if (isZeroTerm(left) || eqTerm(left, right)) { + RETURN_MATCH(NumInt(CPI(term), 0)); + } + + if (isOneTerm(right)) { + RETURN_MATCH(NumInt(CPI(term), 0)); + } + + if (isModTerm(left)) { + inner = getTerm_Mod(left); + if (eqTerm(inner->right, right)) { + RETURN_MATCH(left); + } + } + + RETURN_NO_MATCH(); +} + +static bool tryPowIdentity(Term *term, Term *left, Term *right, Term **result) { + int save = PROTECT(NULL); + TermOp *outer = NULL; + + if (isZeroTerm(right)) { + RETURN_MATCH(NumInt(CPI(term), 1)); + } + if (isOneTerm(right)) { + RETURN_MATCH(left); + } + if (isZeroTerm(left)) { + RETURN_MATCH(NumInt(CPI(term), 0)); + } + if (isOneTerm(left)) { + RETURN_MATCH(NumInt(CPI(term), 1)); + } + + if (isPowTerm(left)) { + outer = getTerm_Pow(left); + Term *exp = Mul(CPI(term), outer->right, right); + RETURN_MATCH(Pow(CPI(term), outer->left, exp)); + } + + RETURN_NO_MATCH(); +} + +#undef RETURN_MATCH +#undef RETURN_NO_MATCH + +static bool tryIdentityFold(Term *term, TermType op, Term *left, Term *right, + Term **result) { + switch (op) { + case TERM_TYPE_ADD: + return tryAddIdentity(term, left, right, result); + case TERM_TYPE_SUB: + return trySubIdentity(term, left, right, result); + case TERM_TYPE_MUL: + return tryMulIdentity(term, left, right, result); + case TERM_TYPE_DIV: + return tryDivIdentity(term, left, right, result); + case TERM_TYPE_MOD: + return tryModIdentity(term, left, right, result); + case TERM_TYPE_POW: + return tryPowIdentity(term, left, right, result); + default: + return false; + } +} + +static Term *rebuildBinaryIfChanged(Term *term, const BinaryOpSpec *spec, + Term *left, Term *right, TermOp *original) { + if (left == original->left && right == original->right) + return term; + + return spec->build(CPI(term), left, right); +} + +static Term *simplifyBinaryOp(Term *term, const BinaryOpSpec *spec, + TermOp *termOp) { + int save = PROTECT(NULL); + Term *left = simplifyTerm(termOp->left); + PROTECT(left); + Term *right = simplifyTerm(termOp->right); + PROTECT(right); + Term *result = NULL; + + if (tryConstantFold(term, spec->op, left, right, &result)) { + UNPROTECT(save); + return result; + } + + if (tryIdentityFold(term, spec->op, left, right, &result)) { + PROTECT(result); + result = simplifyTerm(result); + UNPROTECT(save); + return result; + } + + result = rebuildBinaryIfChanged(term, spec, left, right, termOp); + UNPROTECT(save); + return result; +} + +static Term *simplifyTerm(Term *term) { + if (term == NULL) + return NULL; + + const BinaryOpSpec *spec = lookupBinaryOpSpec(term->type); + if (spec != NULL) + return simplifyBinaryOp(term, spec, spec->get(term)); + + switch (term->type) { + case TERM_TYPE_NUM: + case TERM_TYPE_OTHER: + return term; + default: + cant_happen("unrecognised TermType %s in simplifyTerm", + termTypeName(term->type)); + } +} + +MinExp *simplifyMinExp(MinExp *node) { + if (node == NULL) + return NULL; + + Term *term = minExpToTerm(node); + int save = PROTECT(term); + Term *simplifiedTerm = simplifyTerm(term); + PROTECT(simplifiedTerm); + MinExp *result = termToMinExp(simplifiedTerm); + UNPROTECT(save); + return result; +} diff --git a/src/minlam_simplify.h b/src/minlam_simplify.h new file mode 100644 index 00000000..3607f938 --- /dev/null +++ b/src/minlam_simplify.h @@ -0,0 +1,25 @@ +#ifndef cekf_minlam_simplify_h +#define cekf_minlam_simplify_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "minlam.h" + +MinExp *simplifyMinExp(MinExp *node); + +#endif diff --git a/src/minlam_subst.c b/src/minlam_subst.c new file mode 100644 index 00000000..c8e82510 --- /dev/null +++ b/src/minlam_subst.c @@ -0,0 +1,875 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + * + * Minimal AST after desugaring + * Generated from src/minlam.yaml by tools/generate.py + */ + +#include "memory.h" +#include "minlam.h" +#include "utils_helper.h" + +#include "minlam_subst.h" + +#ifdef DEBUG_MINLAM_SUBST +#include "debugging_on.h" +#else +#include "debugging_off.h" +#endif + +// Forward declarations +static MinLam *substMinLam(MinLam *node, MinExpTable *context); +static MinExprList *substMinExprList(MinExprList *node, MinExpTable *context); +static MinPrimApp *substMinPrimApp(MinPrimApp *node, MinExpTable *context); +static MinApply *substMinApply(MinApply *node, MinExpTable *context); +static MinLookUp *substMinLookUp(MinLookUp *node, MinExpTable *context); +static MinIff *substMinIff(MinIff *node, MinExpTable *context); +static MinCond *substMinCond(MinCond *node, MinExpTable *context); +static MinIntCondCases *substMinIntCondCases(MinIntCondCases *node, + MinExpTable *context); +static MinCharCondCases *substMinCharCondCases(MinCharCondCases *node, + MinExpTable *context); +static MinMatch *substMinMatch(MinMatch *node, MinExpTable *context); +static MinMatchList *substMinMatchList(MinMatchList *node, + MinExpTable *context); +static MinIntList *substMinIntList(MinIntList *node, MinExpTable *context); +static MinLetRec *substMinLetRec(MinLetRec *node, MinExpTable *context); +static MinBindings *substMinBindings(MinBindings *node, MinExpTable *context); +static MinAmb *substMinAmb(MinAmb *node, MinExpTable *context); +static MinAlphaEnv *substMinAlphaEnv(MinAlphaEnv *node, MinExpTable *context); +static MinCondCases *substMinCondCases(MinCondCases *node, + MinExpTable *context); +static SymbolMap *substSymbolMap(SymbolMap *node, MinExpTable *context); +static MinNameSpaceArray *substMinNameSpaceArray(MinNameSpaceArray *node, + MinExpTable *context); +static MinAlphaEnvArray *substMinAlphaEnvArray(MinAlphaEnvArray *node, + MinExpTable *context); + +static MinExpTable *excludeBoundVars(MinExpTable *context, SymbolList *vars) { + MinExpTable *new = newMinExpTable(); + int save = PROTECT(new); + Index i = 0; + HashSymbol *current; + MinExp *exp; + while ((current = iterateMinExpTable(context, &i, &exp)) != NULL) { + if (!symbolInList(current, vars)) { + setMinExpTable(new, current, exp); + } + } + UNPROTECT(save); + return new; +} + +static SymbolList *getBindingVars(MinBindings *bindings) { + SymbolList *vars = NULL; + int save = PROTECT(vars); + while (bindings != NULL) { + vars = newSymbolList(CPI(bindings), bindings->var, vars); + PROTECT(vars); + bindings = bindings->next; + } + UNPROTECT(save); + return vars; +} + +// Visitor implementations + +static MinLam *substMinLam(MinLam *node, MinExpTable *context) { + ENTER(substMinLam); + if (node == NULL) { + LEAVE(substMinLam); + return NULL; + } + + bool changed = false; + MinExpTable *reducedContext = excludeBoundVars(context, node->args); + int save = PROTECT(reducedContext); + MinExp *new_exp = substMinExp(node->exp, reducedContext); + PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + + if (changed) { + // Create new node with modified fields + MinLam *result = newMinLam(CPI(node), node->args, new_exp); + UNPROTECT(save); + LEAVE(substMinLam); + return result; + } + + UNPROTECT(save); + LEAVE(substMinLam); + return node; +} + +static MinExprList *substMinExprList(MinExprList *node, MinExpTable *context) { + ENTER(substMinExprList); + if (node == NULL) { + LEAVE(substMinExprList); + return NULL; + } + + bool changed = false; + MinExp *new_exp = substMinExp(node->exp, context); + int save = PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + MinExprList *new_next = substMinExprList(node->next, context); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + // Create new node with modified fields + MinExprList *result = newMinExprList(CPI(node), new_exp, new_next); + UNPROTECT(save); + LEAVE(substMinExprList); + return result; + } + + UNPROTECT(save); + LEAVE(substMinExprList); + return node; +} + +static MinPrimApp *substMinPrimApp(MinPrimApp *node, MinExpTable *context) { + ENTER(substMinPrimApp); + if (node == NULL) { + LEAVE(substMinPrimApp); + return NULL; + } + + bool changed = false; + // Pass through type (type: MinPrimOp, not memory-managed) + MinExp *new_exp1 = substMinExp(node->exp1, context); + int save = PROTECT(new_exp1); + changed = changed || (new_exp1 != node->exp1); + MinExp *new_exp2 = substMinExp(node->exp2, context); + PROTECT(new_exp2); + changed = changed || (new_exp2 != node->exp2); + + if (changed) { + // Create new node with modified fields + MinPrimApp *result = + newMinPrimApp(CPI(node), node->type, new_exp1, new_exp2); + UNPROTECT(save); + LEAVE(substMinPrimApp); + return result; + } + + UNPROTECT(save); + LEAVE(substMinPrimApp); + return node; +} + +static MinApply *substMinApply(MinApply *node, MinExpTable *context) { + ENTER(substMinApply); + if (node == NULL) { + LEAVE(substMinApply); + return NULL; + } + + bool changed = false; + MinExp *new_function = substMinExp(node->function, context); + int save = PROTECT(new_function); + changed = changed || (new_function != node->function); + MinExprList *new_args = substMinExprList(node->args, context); + PROTECT(new_args); + changed = changed || (new_args != node->args); + + if (changed) { + // Create new node with modified fields + MinApply *result = newMinApply(CPI(node), new_function, new_args); + UNPROTECT(save); + LEAVE(substMinApply); + return result; + } + + UNPROTECT(save); + LEAVE(substMinApply); + return node; +} + +static MinLookUp *substMinLookUp(MinLookUp *node, MinExpTable *context) { + ENTER(substMinLookUp); + if (node == NULL) { + LEAVE(substMinLookUp); + return NULL; + } + + bool changed = false; + // Pass through nsId (type: int, not memory-managed) + MinExp *new_exp = substMinExp(node->exp, context); + int save = PROTECT(new_exp); + changed = changed || (new_exp != node->exp); + + if (changed) { + // Create new node with modified fields + MinLookUp *result = newMinLookUp(CPI(node), node->nsId, new_exp); + UNPROTECT(save); + LEAVE(substMinLookUp); + return result; + } + + UNPROTECT(save); + LEAVE(substMinLookUp); + return node; +} + +static MinIff *substMinIff(MinIff *node, MinExpTable *context) { + ENTER(substMinIff); + if (node == NULL) { + LEAVE(substMinIff); + return NULL; + } + + bool changed = false; + MinExp *new_condition = substMinExp(node->condition, context); + int save = PROTECT(new_condition); + changed = changed || (new_condition != node->condition); + MinExp *new_consequent = substMinExp(node->consequent, context); + PROTECT(new_consequent); + changed = changed || (new_consequent != node->consequent); + MinExp *new_alternative = substMinExp(node->alternative, context); + PROTECT(new_alternative); + changed = changed || (new_alternative != node->alternative); + + if (changed) { + // Create new node with modified fields + MinIff *result = newMinIff(CPI(node), new_condition, new_consequent, + new_alternative); + UNPROTECT(save); + LEAVE(substMinIff); + return result; + } + + UNPROTECT(save); + LEAVE(substMinIff); + return node; +} + +static MinCond *substMinCond(MinCond *node, MinExpTable *context) { + ENTER(substMinCond); + if (node == NULL) { + LEAVE(substMinCond); + return NULL; + } + + bool changed = false; + MinExp *new_value = substMinExp(node->value, context); + int save = PROTECT(new_value); + changed = changed || (new_value != node->value); + MinCondCases *new_cases = substMinCondCases(node->cases, context); + PROTECT(new_cases); + changed = changed || (new_cases != node->cases); + + if (changed) { + // Create new node with modified fields + MinCond *result = newMinCond(CPI(node), new_value, new_cases); + UNPROTECT(save); + LEAVE(substMinCond); + return result; + } + + UNPROTECT(save); + LEAVE(substMinCond); + return node; +} + +static MinIntCondCases *substMinIntCondCases(MinIntCondCases *node, + MinExpTable *context) { + ENTER(substMinIntCondCases); + if (node == NULL) { + LEAVE(substMinIntCondCases); + return NULL; + } + + bool changed = false; + // Pass through constant (type: MaybeBigInt, not memory-managed) + MinExp *new_body = substMinExp(node->body, context); + int save = PROTECT(new_body); + changed = changed || (new_body != node->body); + MinIntCondCases *new_next = substMinIntCondCases(node->next, context); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + // Create new node with modified fields + MinIntCondCases *result = + newMinIntCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + LEAVE(substMinIntCondCases); + return result; + } + + UNPROTECT(save); + LEAVE(substMinIntCondCases); + return node; +} + +static MinCharCondCases *substMinCharCondCases(MinCharCondCases *node, + MinExpTable *context) { + ENTER(substMinCharCondCases); + if (node == NULL) { + LEAVE(substMinCharCondCases); + return NULL; + } + + bool changed = false; + // Pass through constant (type: character, not memory-managed) + MinExp *new_body = substMinExp(node->body, context); + int save = PROTECT(new_body); + changed = changed || (new_body != node->body); + MinCharCondCases *new_next = substMinCharCondCases(node->next, context); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + // Create new node with modified fields + MinCharCondCases *result = + newMinCharCondCases(CPI(node), node->constant, new_body, new_next); + UNPROTECT(save); + LEAVE(substMinCharCondCases); + return result; + } + + UNPROTECT(save); + LEAVE(substMinCharCondCases); + return node; +} + +static MinMatch *substMinMatch(MinMatch *node, MinExpTable *context) { + ENTER(substMinMatch); + if (node == NULL) { + LEAVE(substMinMatch); + return NULL; + } + + bool changed = false; + MinExp *new_index = substMinExp(node->index, context); + int save = PROTECT(new_index); + changed = changed || (new_index != node->index); + MinMatchList *new_cases = substMinMatchList(node->cases, context); + PROTECT(new_cases); + changed = changed || (new_cases != node->cases); + + if (changed) { + // Create new node with modified fields + MinMatch *result = newMinMatch(CPI(node), new_index, new_cases); + UNPROTECT(save); + LEAVE(substMinMatch); + return result; + } + + UNPROTECT(save); + LEAVE(substMinMatch); + return node; +} + +static MinMatchList *substMinMatchList(MinMatchList *node, + MinExpTable *context) { + ENTER(substMinMatchList); + if (node == NULL) { + LEAVE(substMinMatchList); + return NULL; + } + + bool changed = false; + MinIntList *new_matches = substMinIntList(node->matches, context); + int save = PROTECT(new_matches); + changed = changed || (new_matches != node->matches); + MinExp *new_body = substMinExp(node->body, context); + PROTECT(new_body); + changed = changed || (new_body != node->body); + MinMatchList *new_next = substMinMatchList(node->next, context); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + // Create new node with modified fields + MinMatchList *result = + newMinMatchList(CPI(node), new_matches, new_body, new_next); + UNPROTECT(save); + LEAVE(substMinMatchList); + return result; + } + + UNPROTECT(save); + LEAVE(substMinMatchList); + return node; +} + +static MinIntList *substMinIntList(MinIntList *node, MinExpTable *context) { + ENTER(substMinIntList); + if (node == NULL) { + LEAVE(substMinIntList); + return NULL; + } + + bool changed = false; + // Pass through item (type: int, not memory-managed) + MinIntList *new_next = substMinIntList(node->next, context); + int save = PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + // Create new node with modified fields + MinIntList *result = newMinIntList(CPI(node), node->item, new_next); + UNPROTECT(save); + LEAVE(substMinIntList); + return result; + } + + UNPROTECT(save); + LEAVE(substMinIntList); + return node; +} + +static MinLetRec *substMinLetRec(MinLetRec *node, MinExpTable *context) { + ENTER(substMinLetRec); + if (node == NULL) { + LEAVE(substMinLetRec); + return NULL; + } + + SymbolList *vars = getBindingVars(node->bindings); + int save = PROTECT(vars); + MinExpTable *reducedContext = excludeBoundVars(context, vars); + PROTECT(reducedContext); + bool changed = false; + MinBindings *new_bindings = + substMinBindings(node->bindings, reducedContext); + PROTECT(new_bindings); + changed = changed || (new_bindings != node->bindings); + MinExp *new_body = substMinExp(node->body, reducedContext); + PROTECT(new_body); + changed = changed || (new_body != node->body); + + if (changed) { + // Create new node with modified fields + MinLetRec *result = newMinLetRec(CPI(node), new_bindings, new_body); + UNPROTECT(save); + LEAVE(substMinLetRec); + return result; + } + + UNPROTECT(save); + LEAVE(substMinLetRec); + return node; +} + +static MinBindings *substMinBindings(MinBindings *node, MinExpTable *context) { + ENTER(substMinBindings); + if (node == NULL) { + LEAVE(substMinBindings); + return NULL; + } + + bool changed = false; + // Pass through var (type: HashSymbol, not memory-managed) + MinExp *new_val = substMinExp(node->val, context); + int save = PROTECT(new_val); + changed = changed || (new_val != node->val); + MinBindings *new_next = substMinBindings(node->next, context); + PROTECT(new_next); + changed = changed || (new_next != node->next); + + if (changed) { + // Create new node with modified fields + MinBindings *result = + newMinBindings(CPI(node), node->var, new_val, new_next); + UNPROTECT(save); + LEAVE(substMinBindings); + return result; + } + + UNPROTECT(save); + LEAVE(substMinBindings); + return node; +} + +static MinAmb *substMinAmb(MinAmb *node, MinExpTable *context) { + ENTER(substMinAmb); + if (node == NULL) { + LEAVE(substMinAmb); + return NULL; + } + + bool changed = false; + MinExp *new_left = substMinExp(node->left, context); + int save = PROTECT(new_left); + changed = changed || (new_left != node->left); + MinExp *new_right = substMinExp(node->right, context); + PROTECT(new_right); + changed = changed || (new_right != node->right); + + if (changed) { + // Create new node with modified fields + MinAmb *result = newMinAmb(CPI(node), new_left, new_right); + UNPROTECT(save); + LEAVE(substMinAmb); + return result; + } + + UNPROTECT(save); + LEAVE(substMinAmb); + return node; +} + +static MinAlphaEnv *substMinAlphaEnv(MinAlphaEnv *node, MinExpTable *context) { + ENTER(substMinAlphaEnv); + if (node == NULL) { + LEAVE(substMinAlphaEnv); + return NULL; + } + + bool changed = false; + SymbolMap *new_alphaTable = substSymbolMap(node->alphaTable, context); + int save = PROTECT(new_alphaTable); + changed = changed || (new_alphaTable != node->alphaTable); + MinAlphaEnv *new_next = substMinAlphaEnv(node->next, context); + PROTECT(new_next); + changed = changed || (new_next != node->next); + MinAlphaEnvArray *new_nameSpaces = + substMinAlphaEnvArray(node->nameSpaces, context); + PROTECT(new_nameSpaces); + changed = changed || (new_nameSpaces != node->nameSpaces); + + if (changed) { + // Create new node with modified fields + MinAlphaEnv *result = newMinAlphaEnv(new_next); + result->alphaTable = new_alphaTable; + result->nameSpaces = new_nameSpaces; + UNPROTECT(save); + LEAVE(substMinAlphaEnv); + return result; + } + + UNPROTECT(save); + LEAVE(substMinAlphaEnv); + return node; +} + +MinExp *substMinExp(MinExp *node, MinExpTable *context) { + ENTER(substMinExp); + if (node == NULL) { + LEAVE(substMinExp); + return NULL; + } + + if (countMinExpTable(context) == 0) { + LEAVE(substMinExp); + return node; + } + + int save = PROTECT(NULL); + MinExp *result = node; + + switch (node->type) { + case MINEXP_TYPE_AMB: { + // MinAmb + MinAmb *variant = getMinExp_Amb(node); + MinAmb *new_variant = substMinAmb(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Amb(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_APPLY: { + // MinApply + MinApply *variant = getMinExp_Apply(node); + MinApply *new_variant = substMinApply(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Apply(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_BACK: { + // void_ptr + break; + } + case MINEXP_TYPE_BIGINTEGER: { + // MaybeBigInt + break; + } + case MINEXP_TYPE_CALLCC: { + // MinExp + MinExp *variant = getMinExp_CallCC(node); + MinExp *new_variant = substMinExp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_CallCC(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_CHARACTER: { + // character + break; + } + case MINEXP_TYPE_COND: { + // MinCond + MinCond *variant = getMinExp_Cond(node); + MinCond *new_variant = substMinCond(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cond(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_ENV: { + // void_ptr + break; + } + case MINEXP_TYPE_ERROR: { + // void_ptr + break; + } + case MINEXP_TYPE_IFF: { + // MinIff + MinIff *variant = getMinExp_Iff(node); + MinIff *new_variant = substMinIff(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Iff(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LAM: { + // MinLam + MinLam *variant = getMinExp_Lam(node); + MinLam *new_variant = substMinLam(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Lam(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LETREC: { + // MinLetRec + MinLetRec *variant = getMinExp_LetRec(node); + MinLetRec *new_variant = substMinLetRec(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LetRec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_LOOKUP: { + // MinLookUp + MinLookUp *variant = getMinExp_LookUp(node); + MinLookUp *new_variant = substMinLookUp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LookUp(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MAKEVEC: { + // MinExprList + MinExprList *variant = getMinExp_MakeVec(node); + MinExprList *new_variant = substMinExprList(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_MakeVec(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MATCH: { + // MinMatch + MinMatch *variant = getMinExp_Match(node); + MinMatch *new_variant = substMinMatch(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Match(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_NAMESPACES: { + // MinNameSpaceArray + MinNameSpaceArray *variant = getMinExp_NameSpaces(node); + MinNameSpaceArray *new_variant = + substMinNameSpaceArray(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_NameSpaces(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_PRIM: { + // MinPrimApp + MinPrimApp *variant = getMinExp_Prim(node); + MinPrimApp *new_variant = substMinPrimApp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Prim(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_SEQUENCE: { + // MinExprList + MinExprList *variant = getMinExp_Sequence(node); + MinExprList *new_variant = substMinExprList(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Sequence(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_STDINT: { + // int + break; + } + case MINEXP_TYPE_VAR: { + MinExp *res = NULL; + if (getMinExpTable(context, getMinExp_Var(node), &res)) { + result = res; + } + break; + } + default: + cant_happen("unrecognized MinExp type %d", node->type); + } + + UNPROTECT(save); + LEAVE(substMinExp); + return result; +} + +static MinCondCases *substMinCondCases(MinCondCases *node, + MinExpTable *context) { + ENTER(substMinCondCases); + if (node == NULL) { + LEAVE(substMinCondCases); + return NULL; + } + + int save = PROTECT(NULL); + MinCondCases *result = node; + + switch (node->type) { + case MINCONDCASES_TYPE_INTEGERS: { + // MinIntCondCases + MinIntCondCases *variant = getMinCondCases_Integers(node); + MinIntCondCases *new_variant = substMinIntCondCases(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Integers(CPI(node), new_variant); + } + break; + } + case MINCONDCASES_TYPE_CHARACTERS: { + // MinCharCondCases + MinCharCondCases *variant = getMinCondCases_Characters(node); + MinCharCondCases *new_variant = substMinCharCondCases(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Characters(CPI(node), new_variant); + } + break; + } + default: + cant_happen("unrecognized MinCondCases type %d", node->type); + } + + UNPROTECT(save); + LEAVE(substMinCondCases); + return result; +} + +static SymbolMap *substSymbolMap(SymbolMap *node, MinExpTable *context) { + ENTER(substSymbolMap); + if (node == NULL) { + LEAVE(substSymbolMap); + return NULL; + } + + (void)context; // Values are HashSymbol (not memory-managed) +#ifdef NOTDEF + // Iterate over all entries for inspection/logging + Index i = 0; + struct HashSymbol *value; + HashSymbol *key; + while ((key = iterateSymbolMap(node, &i, &value)) != NULL) { + // Inspect/log key and value here + } +#endif + LEAVE(substSymbolMap); + return node; +} + +static MinNameSpaceArray *substMinNameSpaceArray(MinNameSpaceArray *node, + MinExpTable *context) { + ENTER(substMinNameSpaceArray); + if (node == NULL) { + LEAVE(substMinNameSpaceArray); + return NULL; + } + + bool changed = false; + MinNameSpaceArray *result = newMinNameSpaceArray(); + int save = PROTECT(result); + + // Iterate over all elements + for (Index i = 0; i < node->size; i++) { + struct MinExp *element = peeknMinNameSpaceArray(node, i); + struct MinExp *new_element = substMinExp(element, context); + PROTECT(new_element); + changed = changed || (new_element != element); + pushMinNameSpaceArray(result, new_element); + } + + if (changed) { + UNPROTECT(save); + LEAVE(substMinNameSpaceArray); + return result; + } + + UNPROTECT(save); + LEAVE(substMinNameSpaceArray); + return node; +} + +static MinAlphaEnvArray *substMinAlphaEnvArray(MinAlphaEnvArray *node, + MinExpTable *context) { + ENTER(substMinAlphaEnvArray); + if (node == NULL) { + LEAVE(substMinAlphaEnvArray); + return NULL; + } + + bool changed = false; + MinAlphaEnvArray *result = newMinAlphaEnvArray(); + int save = PROTECT(result); + + // Iterate over all elements + for (Index i = 0; i < node->size; i++) { + struct MinAlphaEnv *element = peeknMinAlphaEnvArray(node, i); + struct MinAlphaEnv *new_element = substMinAlphaEnv(element, context); + PROTECT(new_element); + changed = changed || (new_element != element); + pushMinAlphaEnvArray(result, new_element); + } + + if (changed) { + UNPROTECT(save); + LEAVE(substMinAlphaEnvArray); + return result; + } + + UNPROTECT(save); + LEAVE(substMinAlphaEnvArray); + return node; +} diff --git a/src/minlam_subst.h b/src/minlam_subst.h new file mode 100644 index 00000000..d3052367 --- /dev/null +++ b/src/minlam_subst.h @@ -0,0 +1,25 @@ +#ifndef cekf_minlam_subst_h +#define cekf_minlam_subst_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "minlam.h" + +MinExp *substMinExp(MinExp *node, MinExpTable *context); + +#endif diff --git a/src/step.c b/src/step.c index d163a858..453bac1b 100644 --- a/src/step.c +++ b/src/step.c @@ -246,6 +246,10 @@ void run(ByteCodeArray B, LocationArray *L, BuiltIns *builtIns) { static inline int readCurrentByte(void) { return readByte(&state.B, &state.C); } +__attribute__((unused)) static inline int readCurrentShort(void) { + return readShort(&state.B, &state.C); +} + static inline Character readCurrentCharacter(void) { return readCharacter(&state.B, &state.C); } @@ -430,8 +434,8 @@ static Value vec(Value index, Value vector) { int i = index.val.stdint; Vec *vec = vector.val.vec; if (i < 0 || i >= (int)vec->size) - cant_happen("index out of range 0 - %d for vec (%d), location %04lx", - vec->size, i, state.C); + cant_happen("index %d out of range 0 - %d for vec, location %04lx", i, + vec->size - 1, state.C); return vec->entries[i]; } @@ -652,8 +656,13 @@ static void step() { case BYTECODES_TYPE_VAR: { // look up an environment variable and push it +#ifdef SIXTEEN_BIT_ENVIRONMENT + int frame = readCurrentShort(); + int offset = readCurrentShort(); +#else int frame = readCurrentByte(); int offset = readCurrentByte(); +#endif Value v = lookUp(frame, offset); DEBUG("VAR [%d:%d] == %s", frame, offset, valueTypeName(v.type)); push(v); @@ -661,7 +670,11 @@ static void step() { case BYTECODES_TYPE_LVAR: { // look up a stack variable and push it +#ifdef SIXTEEN_BIT_ENVIRONMENT + int offset = readCurrentShort(); +#else int offset = readCurrentByte(); +#endif Value v = peek(offset); DEBUG("LVAR [%d] == %s", offset, valueTypeName(v.type)); push(v); diff --git a/src/term.yaml b/src/term.yaml new file mode 100644 index 00000000..59e60981 --- /dev/null +++ b/src/term.yaml @@ -0,0 +1,59 @@ +# +# CEKF - VM supporting amb +# Copyright (C) 2022-2024 Bill Hails +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +# + +config: + name: term + description: Specific arithmetic structures for performing constant folding. + parserInfo: true + limited_includes: + - minlam.h + - cekfs.h + +cmp: + bespokeImplementation: + - Term + +structs: + TermOp: + data: + left: Term + right: Term + + TermValue: + data: + value: Value + +unions: + Term: + meta: + brief: Top-level Term. + data: + add: TermOp + sub: TermOp + mul: TermOp + div: TermOp + mod: TermOp + pow: TermOp + num: TermValue + other: MinExp + +primitives: !include primitives.yaml + +external: +- !include minlam.yaml +- !include cekfs.yaml \ No newline at end of file diff --git a/src/term_helper.c b/src/term_helper.c new file mode 100644 index 00000000..d587b9c9 --- /dev/null +++ b/src/term_helper.c @@ -0,0 +1,309 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "term_helper.h" + +static MinExp *makeNumericPrimExp(ParserInfo parserInfo, MinPrimOp op, + MinExp *left, MinExp *right) { + int save = PROTECT(left); + PROTECT(right); + MinExp *result = makeMinExp_Prim(parserInfo, op, left, right); + UNPROTECT(save); + return result; +} + +static Value valueToImag(Value value) { + switch (value.type) { + case VALUE_TYPE_STDINT: + return value_Stdint_imag(getValue_Stdint(value)); + case VALUE_TYPE_BIGINT: + return value_Bigint_imag(getValue_Bigint(value)); + case VALUE_TYPE_IRRATIONAL: + return value_Irrational_imag(getValue_Irrational(value)); + case VALUE_TYPE_RATIONAL: + return value_Rational_imag(getValue_Rational(value)); + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + return value; + default: + cant_happen("unsupported ValueType %s in valueToImag", + valueTypeName(value.type)); + } +} + +static MinExp *termValueToMinExp(ParserInfo parserInfo, Value value) { + switch (value.type) { + case VALUE_TYPE_STDINT: { + MaybeBigInt *bigInt = fakeBigInt(value.val.stdint, false); + int save = PROTECT(bigInt); + MinExp *result = newMinExp_BigInteger(parserInfo, bigInt); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_IRRATIONAL: { + MaybeBigInt *bigInt = irrationalBigInt(value.val.irrational, false); + int save = PROTECT(bigInt); + MinExp *result = newMinExp_BigInteger(parserInfo, bigInt); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_BIGINT: { + bigint copied; + bigint_init(&copied); + bigint_cpy(&copied, &value.val.bigint->bi); + MaybeBigInt *bigInt = newMaybeBigInt(copied, false); + int save = PROTECT(bigInt); + MinExp *result = newMinExp_BigInteger(parserInfo, bigInt); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_STDINT_IMAG: { + MaybeBigInt *bigInt = fakeBigInt(value.val.stdint_imag, true); + int save = PROTECT(bigInt); + MinExp *result = newMinExp_BigInteger(parserInfo, bigInt); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_BIGINT_IMAG: { + bigint copied; + bigint_init(&copied); + bigint_cpy(&copied, &value.val.bigint_imag->bi); + MaybeBigInt *bigInt = newMaybeBigInt(copied, true); + int save = PROTECT(bigInt); + MinExp *result = newMinExp_BigInteger(parserInfo, bigInt); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_IRRATIONAL_IMAG: { + MaybeBigInt *bigInt = irrationalBigInt(value.val.irrational_imag, true); + int save = PROTECT(bigInt); + MinExp *result = newMinExp_BigInteger(parserInfo, bigInt); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_RATIONAL: { + Vec *rational = getValue_Rational(value); + MinExp *numerator = termValueToMinExp(parserInfo, rational->entries[0]); + int save = PROTECT(numerator); + MinExp *denominator = + termValueToMinExp(parserInfo, rational->entries[1]); + PROTECT(denominator); + MinExp *result = makeNumericPrimExp(parserInfo, MINPRIMOP_TYPE_DIV, + numerator, denominator); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_RATIONAL_IMAG: { + Vec *rationalImag = getValue_Rational_imag(value); + Value numeratorImag = valueToImag(rationalImag->entries[0]); + MinExp *numerator = termValueToMinExp(parserInfo, numeratorImag); + int save = PROTECT(numerator); + MinExp *denominator = + termValueToMinExp(parserInfo, rationalImag->entries[1]); + PROTECT(denominator); + MinExp *result = makeNumericPrimExp(parserInfo, MINPRIMOP_TYPE_DIV, + numerator, denominator); + UNPROTECT(save); + return result; + } + case VALUE_TYPE_COMPLEX: { + Vec *complex = getValue_Complex(value); + MinExp *real = termValueToMinExp(parserInfo, complex->entries[0]); + int save = PROTECT(real); + MinExp *imag = termValueToMinExp(parserInfo, complex->entries[1]); + PROTECT(imag); + MinExp *result = + makeNumericPrimExp(parserInfo, MINPRIMOP_TYPE_ADD, real, imag); + UNPROTECT(save); + return result; + } + default: + cant_happen("unsupported ValueType %s in termValueToMinExp", + valueTypeName(value.type)); + } +} + +static Term *minBigIntegerToTerm(ParserInfo parserInfo, + MaybeBigInt *maybeBigInt) { + switch (maybeBigInt->type) { + case BI_SMALL: + if (maybeBigInt->imag) { + return makeTerm_Num(parserInfo, + value_Stdint_imag(maybeBigInt->small)); + } + return makeTerm_Num(parserInfo, value_Stdint(maybeBigInt->small)); + case BI_BIG: { + bigint copied; + bigint_init(&copied); + bigint_cpy(&copied, &maybeBigInt->big); + BigInt *runtimeBigInt = newBigInt(copied); + int save = PROTECT(runtimeBigInt); + Term *result = makeTerm_Num( + parserInfo, maybeBigInt->imag ? value_Bigint_imag(runtimeBigInt) + : value_Bigint(runtimeBigInt)); + UNPROTECT(save); + return result; + } + case BI_IRRATIONAL: + if (maybeBigInt->imag) { + return makeTerm_Num(parserInfo, + value_Irrational_imag(maybeBigInt->irrational)); + } + return makeTerm_Num(parserInfo, + value_Irrational(maybeBigInt->irrational)); + default: + cant_happen("unsupported MaybeBigIntType %d in minBigIntegerToTerm", + maybeBigInt->type); + } +} + +static MinExp *termBinaryOpToMinExp(ParserInfo parserInfo, MinPrimOp op, + TermOp *termOp) { + MinExp *left = termToMinExp(termOp->left); + int save = PROTECT(left); + MinExp *right = termToMinExp(termOp->right); + PROTECT(right); + MinExp *result = makeMinExp_Prim(parserInfo, op, left, right); + UNPROTECT(save); + return result; +} + +bool eqTerm(Term *t1, Term *t2) { + if (t1 == t2) + return true; + if (t1 == NULL || t2 == NULL) + return false; + if (t1->type != t2->type) + return false; + switch (t1->type) { + case TERM_TYPE_ADD: + return (eqTerm(getTerm_Add(t1)->left, getTerm_Add(t2)->left) && + eqTerm(getTerm_Add(t1)->right, getTerm_Add(t2)->right)) || + (eqTerm(getTerm_Add(t1)->left, getTerm_Add(t2)->right) && + eqTerm(getTerm_Add(t1)->right, getTerm_Add(t2)->left)); + case TERM_TYPE_SUB: + return eqTerm(getTerm_Sub(t1)->left, getTerm_Sub(t2)->left) && + eqTerm(getTerm_Sub(t1)->right, getTerm_Sub(t2)->right); + case TERM_TYPE_MUL: + return (eqTerm(getTerm_Mul(t1)->left, getTerm_Mul(t2)->left) && + eqTerm(getTerm_Mul(t1)->right, getTerm_Mul(t2)->right)) || + (eqTerm(getTerm_Mul(t1)->left, getTerm_Mul(t2)->right) && + eqTerm(getTerm_Mul(t1)->right, getTerm_Mul(t2)->left)); + case TERM_TYPE_DIV: + return eqTerm(getTerm_Div(t1)->left, getTerm_Div(t2)->left) && + eqTerm(getTerm_Div(t1)->right, getTerm_Div(t2)->right); + case TERM_TYPE_MOD: + return eqTerm(getTerm_Mod(t1)->left, getTerm_Mod(t2)->left) && + eqTerm(getTerm_Mod(t1)->right, getTerm_Mod(t2)->right); + case TERM_TYPE_POW: + return eqTerm(getTerm_Pow(t1)->left, getTerm_Pow(t2)->left) && + eqTerm(getTerm_Pow(t1)->right, getTerm_Pow(t2)->right); + case TERM_TYPE_NUM: + return eqTermValue(getTerm_Num(t1), getTerm_Num(t2)); + case TERM_TYPE_OTHER: + return eqMinExp(getTerm_Other(t1), getTerm_Other(t2)); + default: + cant_happen("unrecognised TermType %d in eqTerm", t1->type); + } +} + +Term *minExpToTerm(struct MinExp *minExp) { + if (minExp == NULL) + return NULL; + if (isMinExp_Stdint(minExp)) { + return newTerm_Other(CPI(minExp), minExp); + } + if (isMinExp_BigInteger(minExp)) { + return minBigIntegerToTerm(CPI(minExp), getMinExp_BigInteger(minExp)); + } + if (isMinExp_Prim(minExp)) { + MinPrimApp *prim = getMinExp_Prim(minExp); + Term *left = minExpToTerm(prim->exp1); + int save = PROTECT(left); + Term *right = minExpToTerm(prim->exp2); + PROTECT(right); + Term *result = NULL; + switch (prim->type) { + case MINPRIMOP_TYPE_ADD: + result = makeTerm_Add(CPI(minExp), left, right); + break; + case MINPRIMOP_TYPE_SUB: + result = makeTerm_Sub(CPI(minExp), left, right); + break; + case MINPRIMOP_TYPE_MUL: + result = makeTerm_Mul(CPI(minExp), left, right); + break; + case MINPRIMOP_TYPE_DIV: + result = makeTerm_Div(CPI(minExp), left, right); + break; + case MINPRIMOP_TYPE_MOD: + result = makeTerm_Mod(CPI(minExp), left, right); + break; + case MINPRIMOP_TYPE_POW: + result = makeTerm_Pow(CPI(minExp), left, right); + break; + default: + result = newTerm_Other(CPI(minExp), minExp); + } + UNPROTECT(save); + return result; + } else { + return newTerm_Other(CPI(minExp), minExp); + } +} + +MinExp *termToMinExp(Term *term) { + if (term == NULL) + return NULL; + switch (term->type) { + case TERM_TYPE_ADD: + return termBinaryOpToMinExp(CPI(term), MINPRIMOP_TYPE_ADD, + getTerm_Add(term)); + case TERM_TYPE_SUB: + return termBinaryOpToMinExp(CPI(term), MINPRIMOP_TYPE_SUB, + getTerm_Sub(term)); + case TERM_TYPE_MUL: + return termBinaryOpToMinExp(CPI(term), MINPRIMOP_TYPE_MUL, + getTerm_Mul(term)); + case TERM_TYPE_DIV: + return termBinaryOpToMinExp(CPI(term), MINPRIMOP_TYPE_DIV, + getTerm_Div(term)); + case TERM_TYPE_MOD: + return termBinaryOpToMinExp(CPI(term), MINPRIMOP_TYPE_MOD, + getTerm_Mod(term)); + case TERM_TYPE_POW: + return termBinaryOpToMinExp(CPI(term), MINPRIMOP_TYPE_POW, + getTerm_Pow(term)); + case TERM_TYPE_NUM: + return termValueToMinExp(CPI(term), getTerm_Num(term)->value); + case TERM_TYPE_OTHER: { + MinExp *other = getTerm_Other(term); + if (isMinExp_Args(other)) { + // args should never survive into real MinExp expressions; it exists + // only to support the alternative normalize_2 path. + cant_happen( + "MINEXP_TYPE_ARGS should not appear in termToMinExp OTHER"); + } + return other; + } + default: + cant_happen("unrecognised TermType %d in termToMinExp", term->type); + } +} \ No newline at end of file diff --git a/src/term_helper.h b/src/term_helper.h new file mode 100644 index 00000000..08f24034 --- /dev/null +++ b/src/term_helper.h @@ -0,0 +1,28 @@ +#ifndef cekf_term_helper_h +#define cekf_term_helper_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "cekfs_debug.h" +#include "minlam_debug.h" +#include "term.h" + +Term *minExpToTerm(struct MinExp *minExp); +MinExp *termToMinExp(Term *term); + +#endif diff --git a/src/types.h b/src/types.h index 1ca8fc48..1f307f37 100644 --- a/src/types.h +++ b/src/types.h @@ -44,6 +44,8 @@ typedef uint8_t Byte; typedef wchar_t Character; typedef unsigned int Word; +typedef short int Short; +typedef unsigned short int ShortIndex; typedef int Integer; typedef unsigned int Index; typedef double Double; diff --git a/src/utils_helper.c b/src/utils_helper.c index b53500d6..e4697ad6 100644 --- a/src/utils_helper.c +++ b/src/utils_helper.c @@ -258,6 +258,27 @@ bool allSymbolsInSet(SymbolList *vars, SymbolSet *symbols) { return true; } +/** + * @brief Return all symbols in the set that are not in the list + * + * @param vars The list of symbols to check. + * @param symbols The set of symbols. + * @return A new set of symbols that are in symbols but not in vars. + */ +SymbolSet *symbolsNotInList(SymbolList *vars, SymbolSet *symbols) { + SymbolSet *new = newSymbolSet(); + int save = PROTECT(new); + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(symbols, &i)) != NULL) { + if (!symbolInList(current, vars)) { + setSymbolSet(new, current); + } + } + UNPROTECT(save); + return new; +} + /** * @brief The union of two sets of symbols. * @param a The first set of symbols. diff --git a/src/utils_helper.h b/src/utils_helper.h index 1970ad83..6636d5f4 100644 --- a/src/utils_helper.h +++ b/src/utils_helper.h @@ -34,6 +34,7 @@ SymbolSet *symbolListToSet(SymbolList *list); SymbolList *symbolSetToList(ParserInfo PI, SymbolSet *set); SymbolSet *excludeSymbol(HashSymbol *var, SymbolSet *symbols); SymbolSet *copySymbolSet(SymbolSet *symbols); +SymbolSet *symbolsNotInList(SymbolList *vars, SymbolSet *symbols); bool symbolInList(HashSymbol *var, SymbolList *vars); SymbolSet *excludeSymbols(SymbolList *vars, SymbolSet *symbols); bool anySymbolInSet(SymbolList *vars, SymbolSet *symbols); diff --git a/tests/fn/test_unification5.fn b/tests/fn/test_unification5.fn index 041118e2..d7b0ce55 100644 --- a/tests/fn/test_unification5.fn +++ b/tests/fn/test_unification5.fn @@ -14,5 +14,4 @@ fn simplify { (x) { x } } in - print simplify(mul(var("x"), var("y"))); assert(simplify(mul(var("x"), var("y"))) == mul(var("x"), var("y"))) \ No newline at end of file diff --git a/tests/src/test_minlam_simplify.c b/tests/src/test_minlam_simplify.c new file mode 100644 index 00000000..9240cce6 --- /dev/null +++ b/tests/src/test_minlam_simplify.c @@ -0,0 +1,880 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include +#include + +#include "arithmetic.h" +#include "bigint.h" +#include "common.h" +#include "init.h" +#include "minlam_pp.h" +#include "minlam_simplify.h" +#include "symbol.h" +#include "term_helper.h" + +#ifdef DEBUG_STRESS_GC +extern int forceGcFlag; +#endif + +typedef void (*TestFn)(void); + +static void runTest(char *name, TestFn testFn) { + printf("%s\n", name); + testFn(); +} + +static MinExp *smallIntExp(int n) { + MaybeBigInt *mbi = fakeBigInt(n, false); + int save = PROTECT(mbi); + MinExp *exp = newMinExp_BigInteger(NULLPI, mbi); + UNPROTECT(save); + return exp; +} + +static MinExp *prim2(MinPrimOp op, MinExp *left, MinExp *right) { + int save = PROTECT(left); + PROTECT(right); + MinExp *result = makeMinExp_Prim(NULLPI, op, left, right); + UNPROTECT(save); + return result; +} + +static MinExp *prim2SmallInts(MinPrimOp op, int left, int right) { + MinExp *leftExp = smallIntExp(left); + int save = PROTECT(leftExp); + MinExp *rightExp = smallIntExp(right); + PROTECT(rightExp); + MinExp *result = prim2(op, leftExp, rightExp); + UNPROTECT(save); + return result; +} + +static MinExp *N(int n) { + MinExp *result = smallIntExp(n); + PROTECT(result); + return result; +} + +static MinExp *V(char *name) { + MinExp *result = newMinExp_Var(NULLPI, newSymbol(name)); + PROTECT(result); + return result; +} + +static MinExp *Vx(void) { return V("x"); } + +static MinExp *Vy(void) { return V("y"); } + +static MinExp *Add(MinExp *left, MinExp *right) { + MinExp *result = prim2(MINPRIMOP_TYPE_ADD, left, right); + PROTECT(result); + return result; +} + +static MinExp *Sub(MinExp *left, MinExp *right) { + MinExp *result = prim2(MINPRIMOP_TYPE_SUB, left, right); + PROTECT(result); + return result; +} + +static MinExp *Mul(MinExp *left, MinExp *right) { + MinExp *result = prim2(MINPRIMOP_TYPE_MUL, left, right); + PROTECT(result); + return result; +} + +static MinExp *Div(MinExp *left, MinExp *right) { + MinExp *result = prim2(MINPRIMOP_TYPE_DIV, left, right); + PROTECT(result); + return result; +} + +static MinExp *Mod(MinExp *left, MinExp *right) { + MinExp *result = prim2(MINPRIMOP_TYPE_MOD, left, right); + PROTECT(result); + return result; +} + +static MinExp *Pow(MinExp *left, MinExp *right) { + MinExp *result = prim2(MINPRIMOP_TYPE_POW, left, right); + PROTECT(result); + return result; +} + +static void assertSimplifiesToInt(MinExp *expr, int expected) { + int save = PROTECT(expr); + MinExp *simplified = simplifyMinExp(expr); + PROTECT(simplified); + Term *asTerm = minExpToTerm(simplified); + PROTECT(asTerm); + assert(asTerm->type == TERM_TYPE_NUM); + Value result = getTerm_Num(asTerm)->value; + assert(ncmp(result, value_Stdint(expected)) == CMP_EQ); + UNPROTECT(save); +} + +static void assertSimplifiesToPrimVars(MinExp *expr, MinPrimOp op, + HashSymbol *left, HashSymbol *right) { + int save = PROTECT(expr); + MinExp *simplified = simplifyMinExp(expr); + PROTECT(simplified); + assert(isMinExp_Prim(simplified)); + MinPrimApp *prim = getMinExp_Prim(simplified); + assert(prim->type == op); + assert(isMinExp_Var(prim->exp1)); + assert(isMinExp_Var(prim->exp2)); + assert(getMinExp_Var(prim->exp1) == left); + assert(getMinExp_Var(prim->exp2) == right); + UNPROTECT(save); +} + +// Compare in Term space for semantic equality; MinExp node shape can differ +// for equivalent expressions, so eqMinExp is too representation-sensitive. +static void assertSimplifiesToExpr(MinExp *expr, MinExp *expected) { + int save = PROTECT(expr); + PROTECT(expected); + MinExp *simplified = simplifyMinExp(expr); + PROTECT(simplified); + Term *simplifiedTerm = minExpToTerm(simplified); + PROTECT(simplifiedTerm); + Term *expectedTerm = minExpToTerm(expected); + PROTECT(expectedTerm); + bool matches = eqTerm(simplifiedTerm, expectedTerm); + if (!matches) { + eprintf("assertSimplifiesToExpr mismatch\n"); + eprintf(" expr: "); + ppMinExp(expr); + eprintf("\n simplified: "); + ppMinExp(simplified); + eprintf("\n expected: "); + ppMinExp(expected); + eprintf("\n"); + } + assert(matches); + UNPROTECT(save); +} + +static void assertMinExpIsInt(MinExp *exp, int expected) { + int save = PROTECT(exp); + Term *asTerm = minExpToTerm(exp); + PROTECT(asTerm); + assert(asTerm->type == TERM_TYPE_NUM); + bool matches = + ncmp(getTerm_Num(asTerm)->value, value_Stdint(expected)) == CMP_EQ; + assert(matches); + UNPROTECT(save); +} + +static void test_const_add(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Add(N(2), N(3)), 5); + UNPROTECT(save); +} + +static void test_mul_zero(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Mul(Vx(), N(0)), 0); + UNPROTECT(save); +} + +static void test_sub_self(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Sub(Vx(), Vx()), 0); + UNPROTECT(save); +} + +static void test_div_self(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Div(Vx(), Vx()), 1); + UNPROTECT(save); +} + +static void test_add_zero_right(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Vx(), N(0)), Vx()); + UNPROTECT(save); +} + +static void test_pow_one(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Pow(Vx(), N(1)), Vx()); + UNPROTECT(save); +} + +static void test_div_one_right(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Vx(), N(1)), Vx()); + UNPROTECT(save); +} + +static void test_div_zero_left(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Div(N(0), Vx()), 0); + UNPROTECT(save); +} + +static void test_mod_self(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Mod(Vx(), Vx()), 0); + UNPROTECT(save); +} + +static void test_mod_zero_left(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Mod(N(0), Vx()), 0); + UNPROTECT(save); +} + +static void test_pow_zero_exponent(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Pow(Vx(), N(0)), 1); + UNPROTECT(save); +} + +static void test_pow_zero_base(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Pow(N(0), Vx()), 0); + UNPROTECT(save); +} + +static void test_pow_one_base(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Pow(N(1), Vx()), 1); + UNPROTECT(save); +} + +static void test_nested_recursive_simplification(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Mul(Vx(), N(1)), Mul(N(0), Vy())), Vx()); + UNPROTECT(save); +} + +static void test_chained_sub_add_zero_to_zero(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Add(Sub(Vx(), Vx()), N(0)), 0); + UNPROTECT(save); +} + +static void test_const_nested_arithmetic(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Mul(Add(N(2), N(3)), Sub(N(4), N(1))), 15); + UNPROTECT(save); +} + +static void test_nested_div_mod_identity_to_zero(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Mod(Div(Vx(), N(1)), Vx()), 0); + UNPROTECT(save); +} + +static void test_nested_pow_constants_to_one(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Add(Pow(N(1), Vx()), Pow(N(0), Vy())), 1); + UNPROTECT(save); +} + +static void test_deep_nested_add_chain_with_var(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(N(1), Add(N(2), Add(N(3), Add(N(4), Vx())))), + Add(N(10), Vx())); + UNPROTECT(save); +} + +static void test_deep_nested_alternating_add_sub(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr( + Add(N(1), Sub(N(2), Add(N(3), Sub(N(4), Add(N(5), Vx()))))), + Add(N(1), Vx())); + UNPROTECT(save); +} + +static void test_deep_nested_division_chain_over_mul(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Div(Div(Mul(N(24), Vx()), N(2)), N(3)), N(4)), + Vx()); + UNPROTECT(save); +} + +static void test_no_simplify_add_vars(void) { + int save = PROTECT(NULL); + assertSimplifiesToPrimVars(Add(Vx(), Vy()), MINPRIMOP_TYPE_ADD, + newSymbol("x"), newSymbol("y")); + UNPROTECT(save); +} + +static void test_no_simplify_div_vars(void) { + int save = PROTECT(NULL); + assertSimplifiesToPrimVars(Div(Vx(), Vy()), MINPRIMOP_TYPE_DIV, + newSymbol("x"), newSymbol("y")); + UNPROTECT(save); +} + +static void test_no_simplify_mod_vars(void) { + int save = PROTECT(NULL); + assertSimplifiesToPrimVars(Mod(Vx(), Vy()), MINPRIMOP_TYPE_MOD, + newSymbol("x"), newSymbol("y")); + UNPROTECT(save); +} + +static void test_no_simplify_pow_vars(void) { + int save = PROTECT(NULL); + assertSimplifiesToPrimVars(Pow(Vx(), Vy()), MINPRIMOP_TYPE_POW, + newSymbol("x"), newSymbol("y")); + UNPROTECT(save); +} + +static void test_mixed_const_fold_without_distribution(void) { + int save = PROTECT(NULL); + HashSymbol *sx = newSymbol("x"); + HashSymbol *sy = newSymbol("y"); + MinExp *expr = Mul(Add(Vx(), Vy()), Add(N(1), N(2))); + + MinExp *simplified = simplifyMinExp(expr); + PROTECT(simplified); + assert(isMinExp_Prim(simplified)); + MinPrimApp *top = getMinExp_Prim(simplified); + assert(top->type == MINPRIMOP_TYPE_MUL); + + assert(isMinExp_Prim(top->exp1)); + MinPrimApp *lhs = getMinExp_Prim(top->exp1); + assert(lhs->type == MINPRIMOP_TYPE_ADD); + assert(isMinExp_Var(lhs->exp1)); + assert(isMinExp_Var(lhs->exp2)); + assert(getMinExp_Var(lhs->exp1) == sx); + assert(getMinExp_Var(lhs->exp2) == sy); + + assertMinExpIsInt(top->exp2, 3); + + UNPROTECT(save); +} + +static void test_add_cancel_negation(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Add(Vx(), Sub(N(0), Vx())), 0); + UNPROTECT(save); +} + +static void test_add_duplicate_to_mul_two(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Vx(), Vx()), Mul(N(2), Vx())); + UNPROTECT(save); +} + +static void test_sub_double_negation(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(N(0), Sub(N(0), Vx())), Vx()); + UNPROTECT(save); +} + +static void test_mul_self_to_pow_two(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(Vx(), Vx()), Pow(Vx(), N(2))); + UNPROTECT(save); +} + +static void test_mul_cancel_division(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(Vx(), Div(Vy(), Vx())), Vy()); + UNPROTECT(save); +} + +static void test_mul_const_into_mul_const_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(N(2), Mul(N(3), Vx())), Mul(N(6), Vx())); + UNPROTECT(save); +} + +static void test_mul_const_into_add_const_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(N(2), Add(N(3), Vx())), + Add(N(6), Mul(N(2), Vx()))); + UNPROTECT(save); +} + +static void test_mul_const_into_sub_const_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(N(2), Sub(N(3), Vx())), + Sub(N(6), Mul(N(2), Vx()))); + UNPROTECT(save); +} + +static void test_mul_const_into_sub_x_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(N(2), Sub(Vx(), N(3))), + Sub(Mul(N(2), Vx()), N(6))); + UNPROTECT(save); +} + +static void test_mul_const_with_div_const_over_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(N(2), Div(N(3), Vx())), Div(N(6), Vx())); + UNPROTECT(save); +} + +static void test_mul_const_with_div_x_over_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(N(8), Div(Vx(), N(2))), Mul(N(4), Vx())); + UNPROTECT(save); +} + +static void test_div_nested_denominator_product(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Div(Vx(), N(2)), N(3)), Div(Vx(), N(6))); + UNPROTECT(save); +} + +static void test_div_const_over_div_const_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(N(8), Div(N(2), Vx())), Mul(N(4), Vx())); + UNPROTECT(save); +} + +static void test_div_const_over_div_x_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(N(8), Div(Vx(), N(2))), Div(N(16), Vx())); + UNPROTECT(save); +} + +static void test_div_mul_const_x_by_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Mul(N(8), Vx()), N(2)), Mul(N(4), Vx())); + UNPROTECT(save); +} + +static void test_div_add_const_x_by_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Add(N(8), Vx()), N(2)), + Add(N(4), Div(Vx(), N(2)))); + UNPROTECT(save); +} + +static void test_div_sub_x_const_by_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Sub(Vx(), N(8)), N(2)), + Sub(Div(Vx(), N(2)), N(4))); + UNPROTECT(save); +} + +static void test_div_pow_by_base_decrements_exponent(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Pow(Vx(), N(3)), Vx()), Pow(Vx(), N(2))); + UNPROTECT(save); +} + +static void test_div_pow_by_pow_same_base_subtracts_exponents(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Pow(Vx(), N(5)), Pow(Vx(), N(2))), + Pow(Vx(), N(3))); + UNPROTECT(save); +} + +static void test_mul_divx_a_mul_divy_b_to_div_xy_ab(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(Div(Vx(), N(2)), Div(Vy(), N(3))), + Div(Mul(Vx(), Vy()), N(6))); + UNPROTECT(save); +} + +static void test_mul_diva_x_mul_divb_y_to_div_ab_xy(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(Div(N(8), Vx()), Div(N(3), Vy())), + Div(N(24), Mul(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_div_divx_a_by_b_to_div_x_ab(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Div(Vx(), N(8)), N(3)), Div(Vx(), N(24))); + UNPROTECT(save); +} + +static void test_div_diva_x_by_b_to_div_ab_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Div(N(12), Vx()), N(3)), Div(N(4), Vx())); + UNPROTECT(save); +} + +static void test_div_divx_a_by_divy_b_to_mul_divxy_ba(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Div(Vx(), N(2)), Div(Vy(), N(6))), + Mul(Div(Vx(), Vy()), N(3))); + UNPROTECT(save); +} + +static void test_div_diva_x_by_divb_y_to_mul_ab_divyx(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Div(N(12), Vx()), Div(N(3), Vy())), + Mul(N(4), Div(Vy(), Vx()))); + UNPROTECT(save); +} + +static void test_add_div_same_denominator_combines(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Div(Vx(), N(2)), Div(Vy(), N(2))), + Div(Add(Vx(), Vy()), N(2))); + UNPROTECT(save); +} + +static void test_sub_div_same_denominator_combines(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Div(Vx(), N(2)), Div(Vy(), N(2))), + Div(Sub(Vx(), Vy()), N(2))); + UNPROTECT(save); +} + +static void test_add_div_same_symbolic_denominator_combines(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Div(Vx(), V("d")), Div(Vy(), V("d"))), + Div(Add(Vx(), Vy()), V("d"))); + UNPROTECT(save); +} + +static void test_div_mul_common_factor_cancels(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Div(Mul(V("k"), Vx()), Mul(V("k"), Vy())), + Div(Vx(), Vy())); + UNPROTECT(save); +} + +static void test_mod_by_one(void) { + int save = PROTECT(NULL); + assertSimplifiesToInt(Mod(Vx(), N(1)), 0); + UNPROTECT(save); +} + +static void test_mod_nested_same_divisor_reduces(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mod(Mod(N(17), Vx()), Vx()), Mod(N(17), Vx())); + UNPROTECT(save); +} + +static void test_mod_nested_different_divisor_no_change(void) { + int save = PROTECT(NULL); + HashSymbol *sx = newSymbol("x"); + HashSymbol *sy = newSymbol("y"); + + MinExp *expr = Mod(Mod(N(17), Vx()), Vy()); + + MinExp *simplified = simplifyMinExp(expr); + PROTECT(simplified); + assert(isMinExp_Prim(simplified)); + MinPrimApp *top = getMinExp_Prim(simplified); + assert(top->type == MINPRIMOP_TYPE_MOD); + assert(isMinExp_Prim(top->exp1)); + MinPrimApp *lhs = getMinExp_Prim(top->exp1); + assert(lhs->type == MINPRIMOP_TYPE_MOD); + assertMinExpIsInt(lhs->exp1, 17); + assert(isMinExp_Var(lhs->exp2)); + assert(getMinExp_Var(lhs->exp2) == sx); + assert(isMinExp_Var(top->exp2)); + assert(getMinExp_Var(top->exp2) == sy); + + UNPROTECT(save); +} + +static void test_pow_nested_exponents_multiply(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Pow(Pow(Vx(), N(2)), N(3)), Pow(Vx(), N(6))); + UNPROTECT(save); +} + +static void test_mul_pow_pow_same_base(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Mul(Pow(Vx(), N(2)), Pow(Vx(), N(3))), + Pow(Vx(), N(5))); + UNPROTECT(save); +} + +static void test_add_const_into_nested_add(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(N(2), Add(N(3), Vx())), Add(N(5), Vx())); + UNPROTECT(save); +} + +static void test_add_const_over_sub_const_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(N(2), Sub(N(3), Vx())), Sub(N(5), Vx())); + UNPROTECT(save); +} + +static void test_add_const_over_sub_x_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(N(5), Sub(Vx(), N(3))), Add(N(2), Vx())); + UNPROTECT(save); +} + +static void test_sub_const_over_add_const_x(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(N(10), Add(N(3), Vx())), Sub(N(7), Vx())); + UNPROTECT(save); +} + +static void test_sub_add_const_x_minus_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Add(N(10), Vx()), N(3)), Add(N(7), Vx())); + UNPROTECT(save); +} + +static void test_sub_sub_x_const_minus_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Sub(Vx(), N(2)), N(3)), Sub(Vx(), N(5))); + UNPROTECT(save); +} + +static void test_sub_const_over_sub_x_const(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(N(10), Sub(Vx(), N(3))), Sub(N(13), Vx())); + UNPROTECT(save); +} + +static void test_add_addnum_addnum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Add(N(2), Vx()), Add(N(3), Vy())), + Add(N(5), Add(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_add_addnum_subnum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Add(N(2), Vx()), Sub(N(3), Vy())), + Add(N(5), Sub(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_add_subother_subother_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Add(Sub(Vx(), N(4)), Sub(Vy(), N(6))), + Sub(Add(Vx(), Vy()), N(10))); + UNPROTECT(save); +} + +static void test_sub_addnum_addnum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Add(N(9), Vx()), Add(N(4), Vy())), + Add(N(5), Sub(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_sub_subother_subother_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Sub(Vx(), N(2)), Sub(Vy(), N(7))), + Add(N(5), Sub(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_sub_subnum_addnum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Sub(N(10), Vx()), Add(N(3), Vy())), + Sub(N(7), Add(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_sub_subother_addnum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Sub(Vx(), N(2)), Add(N(5), Vy())), + Sub(Sub(Vx(), N(7)), Vy())); + UNPROTECT(save); +} + +static void test_sub_addnum_subnum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Add(N(9), Vx()), Sub(N(4), Vy())), + Add(N(5), Add(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_sub_addnum_subothernum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Add(N(9), Vx()), Sub(Vy(), N(4))), + Add(N(13), Sub(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_sub_subnum_subothernum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Sub(N(10), Vx()), Sub(Vy(), N(3))), + Sub(N(13), Add(Vx(), Vy()))); + UNPROTECT(save); +} + +static void test_sub_subothernum_subnum_normalizes(void) { + int save = PROTECT(NULL); + assertSimplifiesToExpr(Sub(Sub(Vx(), N(2)), Sub(N(7), Vy())), + Add(Sub(Vx(), N(9)), Vy())); + UNPROTECT(save); +} + +static void test_dsl_combinatorial_add_sub_matrix(void) { + int constants[] = {2, 5}; + size_t count = sizeof(constants) / sizeof(constants[0]); + + for (size_t i = 0; i < count; i++) { + for (size_t j = 0; j < count; j++) { + int save = PROTECT(NULL); + int a = constants[i]; + int b = constants[j]; + int delta = a - b; + + assertSimplifiesToExpr(Sub(Sub(N(a), Vx()), Add(N(b), Vy())), + Sub(N(delta), Add(Vx(), Vy()))); + + MinExp *expected2 = Add(N(delta), Add(Vx(), Vy())); + if (delta == 0) { + expected2 = Add(Vx(), Vy()); + } + assertSimplifiesToExpr(Sub(Add(N(a), Vx()), Sub(N(b), Vy())), + expected2); + + assertSimplifiesToExpr(Add(Sub(Vx(), N(a)), Sub(Vy(), N(b))), + Sub(Add(Vx(), Vy()), N(a + b))); + + UNPROTECT(save); + } + } +} + +int main(int argc __attribute__((unused)), + char *argv[] __attribute__((unused))) { + initAll(); +#ifdef DEBUG_STRESS_GC + forceGcFlag = 1; +#endif + + runTest("test_const_add", test_const_add); + runTest("test_mul_zero", test_mul_zero); + runTest("test_sub_self", test_sub_self); + runTest("test_div_self", test_div_self); + runTest("test_add_zero_right", test_add_zero_right); + runTest("test_pow_one", test_pow_one); + runTest("test_div_one_right", test_div_one_right); + runTest("test_div_zero_left", test_div_zero_left); + runTest("test_mod_self", test_mod_self); + runTest("test_mod_zero_left", test_mod_zero_left); + runTest("test_pow_zero_exponent", test_pow_zero_exponent); + runTest("test_pow_zero_base", test_pow_zero_base); + runTest("test_pow_one_base", test_pow_one_base); + runTest("test_nested_recursive_simplification", + test_nested_recursive_simplification); + runTest("test_chained_sub_add_zero_to_zero", + test_chained_sub_add_zero_to_zero); + runTest("test_const_nested_arithmetic", test_const_nested_arithmetic); + runTest("test_nested_div_mod_identity_to_zero", + test_nested_div_mod_identity_to_zero); + runTest("test_nested_pow_constants_to_one", + test_nested_pow_constants_to_one); + runTest("test_deep_nested_add_chain_with_var", + test_deep_nested_add_chain_with_var); + runTest("test_deep_nested_alternating_add_sub", + test_deep_nested_alternating_add_sub); + runTest("test_deep_nested_division_chain_over_mul", + test_deep_nested_division_chain_over_mul); + runTest("test_no_simplify_add_vars", test_no_simplify_add_vars); + runTest("test_no_simplify_div_vars", test_no_simplify_div_vars); + runTest("test_no_simplify_mod_vars", test_no_simplify_mod_vars); + runTest("test_no_simplify_pow_vars", test_no_simplify_pow_vars); + runTest("test_mixed_const_fold_without_distribution", + test_mixed_const_fold_without_distribution); + runTest("test_add_cancel_negation", test_add_cancel_negation); + runTest("test_add_duplicate_to_mul_two", test_add_duplicate_to_mul_two); + runTest("test_sub_double_negation", test_sub_double_negation); + runTest("test_mul_self_to_pow_two", test_mul_self_to_pow_two); + runTest("test_mul_cancel_division", test_mul_cancel_division); + runTest("test_mul_const_into_mul_const_x", test_mul_const_into_mul_const_x); + runTest("test_mul_const_into_add_const_x", test_mul_const_into_add_const_x); + runTest("test_mul_const_into_sub_const_x", test_mul_const_into_sub_const_x); + runTest("test_mul_const_into_sub_x_const", test_mul_const_into_sub_x_const); + runTest("test_mul_const_with_div_const_over_x", + test_mul_const_with_div_const_over_x); + runTest("test_mul_const_with_div_x_over_const", + test_mul_const_with_div_x_over_const); + runTest("test_div_nested_denominator_product", + test_div_nested_denominator_product); + runTest("test_div_const_over_div_const_x", test_div_const_over_div_const_x); + runTest("test_div_const_over_div_x_const", test_div_const_over_div_x_const); + runTest("test_div_mul_const_x_by_const", test_div_mul_const_x_by_const); + runTest("test_div_add_const_x_by_const", test_div_add_const_x_by_const); + runTest("test_div_sub_x_const_by_const", test_div_sub_x_const_by_const); + runTest("test_div_pow_by_base_decrements_exponent", + test_div_pow_by_base_decrements_exponent); + runTest("test_div_pow_by_pow_same_base_subtracts_exponents", + test_div_pow_by_pow_same_base_subtracts_exponents); + runTest("test_mul_divx_a_mul_divy_b_to_div_xy_ab", + test_mul_divx_a_mul_divy_b_to_div_xy_ab); + runTest("test_mul_diva_x_mul_divb_y_to_div_ab_xy", + test_mul_diva_x_mul_divb_y_to_div_ab_xy); + runTest("test_div_divx_a_by_b_to_div_x_ab", + test_div_divx_a_by_b_to_div_x_ab); + runTest("test_div_diva_x_by_b_to_div_ab_x", + test_div_diva_x_by_b_to_div_ab_x); + runTest("test_div_divx_a_by_divy_b_to_mul_divxy_ba", + test_div_divx_a_by_divy_b_to_mul_divxy_ba); + runTest("test_div_diva_x_by_divb_y_to_mul_ab_divyx", + test_div_diva_x_by_divb_y_to_mul_ab_divyx); + runTest("test_add_div_same_denominator_combines", + test_add_div_same_denominator_combines); + runTest("test_sub_div_same_denominator_combines", + test_sub_div_same_denominator_combines); + runTest("test_add_div_same_symbolic_denominator_combines", + test_add_div_same_symbolic_denominator_combines); + runTest("test_div_mul_common_factor_cancels", + test_div_mul_common_factor_cancels); + runTest("test_mod_by_one", test_mod_by_one); + runTest("test_mod_nested_same_divisor_reduces", + test_mod_nested_same_divisor_reduces); + runTest("test_mod_nested_different_divisor_no_change", + test_mod_nested_different_divisor_no_change); + runTest("test_pow_nested_exponents_multiply", + test_pow_nested_exponents_multiply); + runTest("test_mul_pow_pow_same_base", test_mul_pow_pow_same_base); + runTest("test_add_const_into_nested_add", test_add_const_into_nested_add); + runTest("test_add_const_over_sub_const_x", test_add_const_over_sub_const_x); + runTest("test_add_const_over_sub_x_const", test_add_const_over_sub_x_const); + runTest("test_sub_const_over_add_const_x", test_sub_const_over_add_const_x); + runTest("test_sub_add_const_x_minus_const", + test_sub_add_const_x_minus_const); + runTest("test_sub_sub_x_const_minus_const", + test_sub_sub_x_const_minus_const); + runTest("test_sub_const_over_sub_x_const", test_sub_const_over_sub_x_const); + runTest("test_add_addnum_addnum_normalizes", + test_add_addnum_addnum_normalizes); + runTest("test_add_addnum_subnum_normalizes", + test_add_addnum_subnum_normalizes); + runTest("test_add_subother_subother_normalizes", + test_add_subother_subother_normalizes); + runTest("test_sub_addnum_addnum_normalizes", + test_sub_addnum_addnum_normalizes); + runTest("test_sub_subother_subother_normalizes", + test_sub_subother_subother_normalizes); + runTest("test_sub_subnum_addnum_normalizes", + test_sub_subnum_addnum_normalizes); + runTest("test_sub_subother_addnum_normalizes", + test_sub_subother_addnum_normalizes); + runTest("test_sub_addnum_subnum_normalizes", + test_sub_addnum_subnum_normalizes); + runTest("test_sub_addnum_subothernum_normalizes", + test_sub_addnum_subothernum_normalizes); + runTest("test_sub_subnum_subothernum_normalizes", + test_sub_subnum_subothernum_normalizes); + runTest("test_sub_subothernum_subnum_normalizes", + test_sub_subothernum_subnum_normalizes); + runTest("test_dsl_combinatorial_add_sub_matrix", + test_dsl_combinatorial_add_sub_matrix); + + return 0; +} diff --git a/tests/src/test_term_helper.c b/tests/src/test_term_helper.c new file mode 100644 index 00000000..73db7fc7 --- /dev/null +++ b/tests/src/test_term_helper.c @@ -0,0 +1,273 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2026 Bill Hails + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include +#include + +#include "bigint.h" +#include "common.h" +#include "init.h" +#include "term_helper.h" + +typedef void (*TestFn)(void); + +static void runTest(char *name, TestFn testFn) { + printf("%s\n", name); + testFn(); +} + +static void assertRoundTripMinExp(MinExp *orig) { + int save = PROTECT(orig); + Term *term = minExpToTerm(orig); + PROTECT(term); + MinExp *back = termToMinExp(term); + PROTECT(back); + assert(eqMinExp(orig, back)); + UNPROTECT(save); +} + +static void assertTermNumMapsToSmall(Value value, bool imag, int expected) { + Term *term = makeTerm_Num(NULLPI, value); + int save = PROTECT(term); + MinExp *exp = termToMinExp(term); + PROTECT(exp); + assert(isMinExp_BigInteger(exp)); + MaybeBigInt *mbi = getMinExp_BigInteger(exp); + assert(mbi->type == BI_SMALL); + assert(mbi->imag == imag); + assert(mbi->small == expected); + UNPROTECT(save); +} + +static void assertTermNumMapsToIrrational(Value value, bool imag, + Double expected) { + Term *term = makeTerm_Num(NULLPI, value); + int save = PROTECT(term); + MinExp *exp = termToMinExp(term); + PROTECT(exp); + assert(isMinExp_BigInteger(exp)); + MaybeBigInt *mbi = getMinExp_BigInteger(exp); + assert(mbi->type == BI_IRRATIONAL); + assert(mbi->imag == imag); + assert(mbi->irrational == expected); + UNPROTECT(save); +} + +static void assertTermNumMapsToBig(Value value, bool imag, BigInt *expected) { + Term *term = makeTerm_Num(NULLPI, value); + int save = PROTECT(term); + MinExp *exp = termToMinExp(term); + PROTECT(exp); + assert(isMinExp_BigInteger(exp)); + MaybeBigInt *mbi = getMinExp_BigInteger(exp); + assert(mbi->type == BI_BIG); + assert(mbi->imag == imag); + assert(bigint_cmp(&mbi->big, &expected->bi) == 0); + UNPROTECT(save); +} + +static void assertSmallBigIntegerLiteral(MinExp *exp, bool imag, int expected) { + assert(isMinExp_BigInteger(exp)); + MaybeBigInt *mbi = getMinExp_BigInteger(exp); + assert(mbi->type == BI_SMALL); + assert(mbi->imag == imag); + assert(mbi->small == expected); +} + +static MinExp *makeSmallBigInteger(int n, bool imag) { + MaybeBigInt *mbi = fakeBigInt(n, imag); + int save = PROTECT(mbi); + MinExp *exp = newMinExp_BigInteger(NULLPI, mbi); + UNPROTECT(save); + return exp; +} + +static MinExp *makeLargeBigInteger(int n, bool imag) { + bigint bi; + bigint_init(&bi); + bigint_from_int(&bi, n); + MaybeBigInt *mbi = newMaybeBigInt(bi, imag); + int save = PROTECT(mbi); + MinExp *exp = newMinExp_BigInteger(NULLPI, mbi); + UNPROTECT(save); + return exp; +} + +static void test_round_trip_large_bigint(void) { + MinExp *orig = makeLargeBigInteger(123456, false); + assertRoundTripMinExp(orig); +} + +static void test_round_trip_small_bigint_is_preserved(void) { + MinExp *orig = makeSmallBigInteger(42, false); + assertRoundTripMinExp(orig); +} + +static void test_round_trip_small_imag_bigint_is_preserved(void) { + MinExp *orig = makeSmallBigInteger(7, true); + assertRoundTripMinExp(orig); +} + +static void test_round_trip_irrational_bigint_is_preserved(void) { + MaybeBigInt *mbi = irrationalBigInt(3.5, false); + int save = PROTECT(mbi); + MinExp *orig = newMinExp_BigInteger(NULLPI, mbi); + PROTECT(orig); + assertRoundTripMinExp(orig); + UNPROTECT(save); +} + +static void test_round_trip_minexp_stdint_is_other(void) { + MinExp *orig = newMinExp_Stdint(NULLPI, 9); + int save = PROTECT(orig); + Term *term = minExpToTerm(orig); + PROTECT(term); + assert(term->type == TERM_TYPE_OTHER); + MinExp *back = termToMinExp(term); + PROTECT(back); + assert(eqMinExp(orig, back)); + UNPROTECT(save); +} + +static void test_term_num_stdint_maps_to_biginteger_small(void) { + assertTermNumMapsToSmall(value_Stdint(21), false, 21); +} + +static void test_term_num_stdint_imag_maps_to_biginteger_small_imag(void) { + assertTermNumMapsToSmall(value_Stdint_imag(22), true, 22); +} + +static void test_term_num_irrational_maps_to_biginteger_irrational(void) { + assertTermNumMapsToIrrational(value_Irrational(2.5), false, 2.5); +} + +static void +test_term_num_irrational_imag_maps_to_biginteger_irrational_imag(void) { + assertTermNumMapsToIrrational(value_Irrational_imag(2.75), true, 2.75); +} + +static void test_term_num_bigint_maps_to_biginteger_big(void) { + BigInt *runtimeBigInt = bigIntFromInt(314159); + int save = PROTECT(runtimeBigInt); + assertTermNumMapsToBig(value_Bigint(runtimeBigInt), false, runtimeBigInt); + UNPROTECT(save); +} + +static void test_term_num_bigint_imag_maps_to_biginteger_big_imag(void) { + BigInt *runtimeBigInt = bigIntFromInt(271828); + int save = PROTECT(runtimeBigInt); + assertTermNumMapsToBig(value_Bigint_imag(runtimeBigInt), true, + runtimeBigInt); + UNPROTECT(save); +} + +static void test_term_num_rational_maps_to_div_expression(void) { + Vec *ratio = newVec(2); + int save = PROTECT(ratio); + ratio->entries[0] = value_Stdint(3); + ratio->entries[1] = value_Stdint(4); + + Term *term = makeTerm_Num(NULLPI, value_Rational(ratio)); + PROTECT(term); + MinExp *exp = termToMinExp(term); + PROTECT(exp); + + assert(isMinExp_Prim(exp)); + MinPrimApp *prim = getMinExp_Prim(exp); + assert(prim->type == MINPRIMOP_TYPE_DIV); + assertSmallBigIntegerLiteral(prim->exp1, false, 3); + assertSmallBigIntegerLiteral(prim->exp2, false, 4); + + UNPROTECT(save); +} + +static void test_term_num_rational_imag_maps_to_div_expression(void) { + Vec *ratio = newVec(2); + int save = PROTECT(ratio); + ratio->entries[0] = value_Stdint(5); + ratio->entries[1] = value_Stdint(6); + + Term *term = makeTerm_Num(NULLPI, value_Rational_imag(ratio)); + PROTECT(term); + MinExp *exp = termToMinExp(term); + PROTECT(exp); + + assert(isMinExp_Prim(exp)); + MinPrimApp *prim = getMinExp_Prim(exp); + assert(prim->type == MINPRIMOP_TYPE_DIV); + assertSmallBigIntegerLiteral(prim->exp1, true, 5); + assertSmallBigIntegerLiteral(prim->exp2, false, 6); + + UNPROTECT(save); +} + +static void test_term_num_complex_maps_to_add_expression(void) { + Vec *complex = newVec(2); + int save = PROTECT(complex); + complex->entries[0] = value_Stdint(2); + complex->entries[1] = value_Stdint_imag(7); + + Term *term = makeTerm_Num(NULLPI, value_Complex(complex)); + PROTECT(term); + MinExp *exp = termToMinExp(term); + PROTECT(exp); + + assert(isMinExp_Prim(exp)); + MinPrimApp *prim = getMinExp_Prim(exp); + assert(prim->type == MINPRIMOP_TYPE_ADD); + assertSmallBigIntegerLiteral(prim->exp1, false, 2); + assertSmallBigIntegerLiteral(prim->exp2, true, 7); + + UNPROTECT(save); +} + +int main(int argc __attribute__((unused)), + char *argv[] __attribute__((unused))) { + initAll(); + + runTest("test_round_trip_large_bigint", test_round_trip_large_bigint); + runTest("test_round_trip_small_bigint_is_preserved", + test_round_trip_small_bigint_is_preserved); + runTest("test_round_trip_small_imag_bigint_is_preserved", + test_round_trip_small_imag_bigint_is_preserved); + runTest("test_round_trip_irrational_bigint_is_preserved", + test_round_trip_irrational_bigint_is_preserved); + runTest("test_round_trip_minexp_stdint_is_other", + test_round_trip_minexp_stdint_is_other); + + runTest("test_term_num_stdint_maps_to_biginteger_small", + test_term_num_stdint_maps_to_biginteger_small); + runTest("test_term_num_stdint_imag_maps_to_biginteger_small_imag", + test_term_num_stdint_imag_maps_to_biginteger_small_imag); + runTest("test_term_num_irrational_maps_to_biginteger_irrational", + test_term_num_irrational_maps_to_biginteger_irrational); + runTest("test_term_num_irrational_imag_maps_to_biginteger_irrational_imag", + test_term_num_irrational_imag_maps_to_biginteger_irrational_imag); + runTest("test_term_num_bigint_maps_to_biginteger_big", + test_term_num_bigint_maps_to_biginteger_big); + runTest("test_term_num_bigint_imag_maps_to_biginteger_big_imag", + test_term_num_bigint_imag_maps_to_biginteger_big_imag); + runTest("test_term_num_rational_maps_to_div_expression", + test_term_num_rational_maps_to_div_expression); + runTest("test_term_num_rational_imag_maps_to_div_expression", + test_term_num_rational_imag_maps_to_div_expression); + runTest("test_term_num_complex_maps_to_add_expression", + test_term_num_complex_maps_to_add_expression); + + return 0; +} diff --git a/tools/generate.py b/tools/generate.py index a562e96e..52f93570 100755 --- a/tools/generate.py +++ b/tools/generate.py @@ -267,6 +267,8 @@ def generate_header(args, catalog, document, packageName, includes, limited_incl catalog.printGetterDeclarations() printSection("discriminated union setter declarations") catalog.printSetterDeclarations() + printSection("discriminated union is-tester declarations") + catalog.printIsTesterDeclarations() printSection("eq declarations") catalog.printEqDeclarations() print("") diff --git a/tools/generate/base.py b/tools/generate/base.py index 5883aa32..4591e28d 100644 --- a/tools/generate/base.py +++ b/tools/generate/base.py @@ -159,6 +159,9 @@ def printGetterDeclarations(self, catalog): def printSetterDeclarations(self, catalog): pass + def printIsTesterDeclarations(self, catalog): + pass + def printNameFunctionDeclaration(self): pass diff --git a/tools/generate/catalog.py b/tools/generate/catalog.py index cf0756be..e8b21b5d 100644 --- a/tools/generate/catalog.py +++ b/tools/generate/catalog.py @@ -81,6 +81,9 @@ def printGetterDeclarations(self): def printSetterDeclarations(self): self._dispatch('printSetterDeclarations', self) + def printIsTesterDeclarations(self): + self._dispatch('printIsTesterDeclarations', self) + def generateVisitor(self, packageName, target): """Generate complete visitor boilerplate""" output = [] @@ -106,6 +109,8 @@ def generateVisitor(self, packageName, target): # Forward declarations output.append("// Forward declarations\n") for entity in self.contents.values(): + if entity.isExternal(): + continue decl = entity.generateVisitorDecl(target) if decl: output.append(decl) @@ -114,6 +119,8 @@ def generateVisitor(self, packageName, target): # Implementations output.append("// Visitor implementations\n") for entity in self.contents.values(): + if entity.isExternal(): + continue impl = entity.generateVisitor(self, target) if impl: output.append(impl) diff --git a/tools/generate/discriminated_union.py b/tools/generate/discriminated_union.py index 472c355a..fd15eaeb 100644 --- a/tools/generate/discriminated_union.py +++ b/tools/generate/discriminated_union.py @@ -60,6 +60,10 @@ def printSetterDeclarations(self, catalog): for field in self.fields: field.printSetterDeclaration(catalog, self, self.isInline(catalog)) + def printIsTesterDeclarations(self, catalog): + for field in self.fields: + field.printIsTesterDeclaration(catalog, self, self.isInline(catalog)) + def getNewArgs(self, catalog): return [self.enum, self.union] diff --git a/tools/generate/discriminated_union_field.py b/tools/generate/discriminated_union_field.py index 56741a27..237ee01c 100644 --- a/tools/generate/discriminated_union_field.py +++ b/tools/generate/discriminated_union_field.py @@ -158,6 +158,25 @@ def printSetterDeclaration(self, catalog, owner, isInline): print(f'}} {c}') print('') + def printIsTesterDeclaration(self, catalog, owner, isInline): + """ + Generate is_ inline function that tests if the union + is the specified variant type. + + Example: static inline bool isLamExp_Iff(struct LamExp *_x) + """ + c = self.comment('printIsTesterDeclaration') + ucfirst = self.getName()[0].upper() + self.getName()[1:] + typeName = self.makeTypeName() + ownerType = owner.getTypeDeclaration(catalog) + accessor = '.' if isInline else '->' + + # Generate the inline tester function + print(f'static inline bool is{self.owner}_{ucfirst}({ownerType}_x) {{ {c}') + print(f' return _x{accessor}type == {typeName}; {c}') + print(f'}} {c}') + print('') + def printStructTypedefLine(self, catalog): c = self.comment('printStructTypedefLine') obj = catalog.get(self.typeName) diff --git a/tools/generate/inline_discriminated_union.py b/tools/generate/inline_discriminated_union.py index 4b5fba0f..464a0efa 100644 --- a/tools/generate/inline_discriminated_union.py +++ b/tools/generate/inline_discriminated_union.py @@ -69,10 +69,20 @@ def objTypeArray(self): return [] def printCopyDeclaration(self, catalog): - pass + c = self.comment('printCopyDeclaration') + decl = self.getCopySignature(catalog) + print(f"{decl}; {c}") def printCopyFunction(self, catalog): - pass + c = self.comment('printCopyFunction') + decl = self.getCopySignature(catalog) + myName = self.getName() + print(f"/**") + print(f" * Copies a {myName} union (returns by value).") + print(f" */") + print(f"{decl} {{ {c}") + print(f" return o; {c}") + print(f"}} {c}\n") def generateVisitorDecl(self): """Generate forward declaration for union visitor (dispatcher + variants)"""