diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 6099c8c0..eed9d036 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -2,572 +2,140 @@ ## Project Overview -CEKF is a **bytecode-based functional programming language VM** implementing a CEK machine (Control, Environment, Kontinuation) plus "F" for failure continuation supporting `amb` non-deterministic programming. Written in C with Python code generation tools. - -**Core Innovation**: Backtracking via failure continuations. The `amb` operator (spelled `then` in the language) creates decision points; `back` backtracks to try alternatives. See `fn/barrels.fn` for a canonical example. +CEKF, a.k.a. F♮ is a **bytecode-based functional programming language VM** Written in C with Python code generation tools. ## Architecture Pipeline -Source flows through these stages (see README.md flowchart): - -1. **Scanner** (`src/pratt_scanner.c`) → Tokens -2. **Pratt Parser** (`src/pratt_parser.c`) → AST (`src/ast.yaml`) -3. **Lambda Conversion** (`src/lambda_conversion.c`) → Plain Lambda Form (`src/lambda.yaml`) - - Includes **TPMC** (Term Pattern Matching Compiler, `src/tpmc_*.c`) - see detailed section below - - **Macro Expansion** (`src/macro_substitution.c`) - - **Print Generator** (`src/print_generator.c`) - auto-generates print functions for typedefs -4. **Type Checking** (`src/tc_analyze.c`) - Hindley-Milner Algorithm W using Prolog-style logical variables -5. **Constructor Inlining** (`src/inline.c`) -6. **ANF Conversion** (`src/anf_normalize.c`) → A-Normal Form (`src/anf.yaml`) - see detailed section below -7. **Lexical Analysis** (`src/annotate.c`) - De Bruijn indexing for fast variable lookup -8. **Bytecode Compiler** (`src/bytecode.c`) → Bytecode (`src/cekfs.yaml`) -9. **CEKF Runtime** (`src/step.c`) - The virtual machine - -## Critical Build System Knowledge - -### Code Generation (`tools/generate.py` and `tools/generate/`) - -**The build depends heavily on Python code generation**. DO NOT manually edit files in `generated/`! - -#### Overview -The code generator is now 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. The old monolithic `makeAST.py` has been fully refactored into modules such as `catalog.py`, `primitives.py`, `fields.py`, `structs.py`, `unions.py`, `arrays.py`, `vectors.py`, `hashes.py`, and more. All code generation is now managed through this modular structure. - -#### YAML Schema Structure - -Each `.yaml` file in `src/` defines structures for a compiler stage: - -```yaml -config: - name: # e.g., "ast", "lambda", "anf", "cekfs" - description: "..." # Purpose of this stage - parserInfo: true # Include ParserInfo in structs - limited_includes: # Additional headers needed - - bigint.h - -structs: - StructName: - meta: - brief: "Short description" - description: "Detailed description" - data: - fieldName: fieldType - autoInitField: type=initValue # Constructor auto-initializes, not a parameter - -unions: - UnionName: - data: - variantName: StructName - -arrays: - ArrayName: - entries: ElementType - -hashes: - HashName: - data: - entries: ValueType -``` - -#### Primitives (`src/primitives.yaml`) - -Common types shared across all stages - referenced via `!include primitives.yaml`: -- `HashSymbol` - Symbol table entries (always a pointer) -- `int`, `bool`, `char`, `character` - Basic types -- `BigInt`, `MaybeBigInt` - Arbitrary precision integers -- `file_id` - Source file tracking -- Each has `cname`, `printf`/`printFn`, optionally `markFn`, `compareFn` - -#### Generated Functions - -For each struct/union, the code generator (via `tools/generate.py` and the `generate` package) generates: - -**Memory Management:** -- `new()` - Allocator with GC header, takes all fields as args -- `new_()` - Creates discriminated union variant in type-safe way -- `make_()` - Creates the Component and wraps in union -- `copy()` - Deep copy -- `mark()` - Recursive GC marking -- `free()` - Cleanup (called by GC) - -**Arrays/Stacks/Vectors:** -- `new()` - Create with initial capacity -- `push()` - Append element -- `pop()` - Remove last element -- `peek()` - Access element without removing -- `poke()` - Set element at index - -**Hash Tables:** -- `new()` - Create hash table -- `get()` - Retrieve value by key -- `set()` - Store value by key -- Iterator functions for traversal - -**Debugging (in `*_debug.{c,h}`):** -- `print()` - Pretty-print for debugging -- `eq()` - Deep equality for testing -- `typenameObj()` - String name of type +Source flows through these stages: -**Object Types (in `*_objtypes.h`):** -- Enum of all object types for GC -- Switch case macros for dispatch -- Generic `mark*Obj()`, `free*Obj()`, `typename*Obj()` dispatchers +1. **Scanner** (`src/pratt_scanner.c`) (text → [`PrattToken`](../src/pratt.yaml)) — *see [pratt-parser.md](../docs/agent/pratt-parser.md)* +2. **Pratt Parser** (`src/pratt_parser.c`) → AST (`PrattToken*` → [`AstNode*`](../src/ast.yaml)) — *see [pratt-parser.md](../docs/agent/pratt-parser.md)* +3. **Lambda Conversion** (`src/lambda_conversion.c`) → Plain Lambda Form (`AstNode*` → [`LamExp*`](../src/lambda.yaml)) + - Includes **TPMC** (Term Pattern Matching Compiler, `src/tpmc_*.c`) — *see [tpmc.md](../docs/agent/tpmc.md)* + - **Lazy Function Expansion** (`src/macro_substitution.c`) + - **Print Generator** (`src/print_generator.c`) +4. **Type Checking** (`src/tc_analyze.c`) - Hindley-Milner Algorithm W using Prolog-style logical variables (`LamExp*` → [`TcType*`](../src/tc.yaml)) +5. **Constructor Inlining** (`src/inline.c`) (`LamExp*` → `LamExp*`) +6. **Desugaring** (`src/lambda_desugar.c`) - Simplifies syntactic sugar (`LamExp*` → [`MinExp*`](../src/minlam.yaml)) +7. **Alpha Conversion** (`src/lambda_alphaconvert.c`) - Renames variables to avoid capture (`MinExp*` → `MinExp*`) +8. **ANF Conversion** (`src/anf_normalize.c`) → A-Normal Form (`MinExp*` → [`AnfExp*`](../src/anf.yaml)) — *see [anf.md](../docs/agent/anf.md)* +9. **Lexical Analysis** (`src/annotate.c`) - De Bruijn indexing for fast variable lookup (`AnfExp*` → `AnfExp*`) +10. **Bytecode Compiler** (`src/bytecode.c`) → Bytecode (`AnfExp*` → [`ByteCodeArray`](../src/cekfs.yaml)) +11. **CEKF Runtime** (`src/step.c`) - The virtual machine -#### Extended Features for Generated Unions +## Build System -- `new_(variant)` creates a union from an existing variant with the correct discriminating tag. -- `make_(fields...)` creates the variant and wraps it in the union in one step. -- `get_(unionPtr)` extracts the variant from the union, throwing an error if the type does not match. +The system uses GNU make, and targets CLang or GCC. -#### Key Classes in `makeAST.py` +### Code Generation -The main classes are now in the `generate` package: -- `Catalog` - Manages all entities in a YAML file, orchestrates generation -- `SimpleStruct`, `DiscriminatedUnion`, `SimpleArray`, `SimpleStack`, `SimpleHash`, `SimpleVector`, `SimpleEnum`, `Primitive`, and more, each in their own module. +The build depends heavily on code generation. Do not manually edit files in `generated/`. See [code-generation.md](../docs/agent/code-generation.md) for details. -#### Usage Pattern +### Build Modes -1. **Define structures** in `src/.yaml` -2. **Run make** - triggers `generate.py` for each YAML (via Makefile) -3. **Generated files** appear in `generated/` -4. **Include headers** in your C code: `#include ".h"` -5. **Use generated functions** - no manual memory management code needed - -#### Important Notes - -- **ParserInfo**: If `parserInfo: true`, all structs get `ParserInfo I` field for error reporting -- **Auto-initialized fields**: Use `field: type=value` syntax in YAML to have constructor initialize the field automatically rather than requiring it as a parameter -- **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 - -#### When Adding New Structures - -1. Add to appropriate `src/*.yaml` file -2. Define in `structs:`, `unions:`, `arrays:`, or `hashes:` section -3. Add `meta` documentation (optional but recommended) -4. Run `make` - regeneration is automatic -5. Include generated header in C files that use the new types -6. **For GC-managed types**: If the YAML generates `*_objtypes.h`: - - Include the generated `*_objtypes.h` file in `src/memory.h` - - Add the `*_OBJTYPES()` macro to the `ObjType` enum at the bottom of `memory.h` - - This registers the types with the garbage collector - -#### Debugging Generation - -If generated code looks wrong: -- Check YAML syntax (especially indentation) -- Verify types are defined (either in same YAML or `primitives.yaml`) -- Look at similar existing definitions as templates -- Run `python3 tools/generate.py src/.yaml h` manually to see errors - -### Build Modes (via `MODE=` variable) +(via `MODE=` variable): ```bash -make # debugging mode: -g, forces GC on every malloc -make MODE=testing # -g without aggressive GC -make MODE=unit # enables UNIT_TESTS +make # default MODE=debug: -g, enables `--stress-gc` flag which will force GC on every malloc +make MODE=testing # -g without aggressive GC option make MODE=production # -O2, all safety checks disabled ``` ### Key Make Targets ```bash -make test # Runs C unit tests + all tests/fn/test_*.fn files +make test # Builds then runs C unit tests + all tests/fn/test_*.fn files make profile # Builds then runs callgrind profiling make leak-check # Runs valgrind memory leak detection make docs # Generates Mermaid diagrams from YAML schemas -make indent # Formats code with GNU indent ``` -## Language Syntax (`.fn` files) - -### Core Syntax -- **Functions**: `fn name { (args) { body } }` or `let name = fn(args) { body }` -- **Let/In blocks**: `let` declarations `in` expressions - - `let` introduces mutually recursive definitions (letrec semantics) - - `in` begins the body that uses those definitions - - Can appear at file top-level or inside any `{ }` block - - Without `let`/`in`, blocks are just sequences of expressions - - **IMPORTANT**: Nested `let/in` blocks must be enclosed in curly braces: `let x = 1; in { let y = 2; in y + x }` -- **Pattern Matching**: Functions can have multiple cases, switch on arguments - - Wildcards: `_` matches anything without binding - - Named structures: `x = h @ t` binds both components and whole - - Pseudo-unification: `(x, x @ _)` requires matching values - - Switch expressions: `switch (expr) { (pattern) { result } }` -- **Typedefs**: `typedef typename(#generic) { constructor1(types) | constructor2 }` - - Generic types use `#` prefix: `#t`, `#a`, `#b` - - Built-in types: `int`, `char`, `bool`, `string` (alias for `list(char)`) - - Named fields: `constructor{ fieldName: type }` - - **IMPORTANT**: Typedefs at `namespace` level are global; typedefs inside `let` blocks are scoped to that block -- **Operators**: Defined in `src/preamble.fn` (e.g., `@` = cons, `@@` = append) -- **Namespaces**: Files start with `namespace` keyword (like `let` without `in` - mutually recursive declarations) - - **IMPORTANT**: `link` directives must appear inside a `let` or `namespace` block, not at top level - - Import via `link ".fn" as ` (inside `let`) - - Reference imported components as `name.component` - - Example: - ```fn - let - link "listutils.fn" as lst; - result = lst.length([1, 2, 3]); - in - result - ``` - -### Common Syntax Gotchas -- **Link placement**: `link` statements MUST be inside a `let` or `namespace` block, not standalone -- **Nested blocks**: Nested `let/in` require `{ }` around the `let/in` expression -- **Semicolons in let**: Multiple bindings in `let` are separated by semicolons: `let a = 1; b = 2; in a + b` -- **Variable naming**: Identifiers starting with `fn` followed by a digit (like `fn3`, `fn10`) are rejected by the parser - use different names like `func3`, `f3` -- **Division operator**: `/` will produce rationals, not integer quotient. -- **Print declarations**: `print typename { ... }` is a declaration, not a function call - defines custom printer for a type -- **Exhaustive patterns**: Pattern matches must be exhaustive unless function or switch is declared `unsafe` - -### Non-Deterministic Programming (amb) -- **`then`**: Right-associative binary operator - evaluates LHS, but if backtracked returns RHS -- **`back`**: Triggers backtracking to most recent `then` -- Not just try/catch - can backtrack to any chronologically previous `then` in the history of the process -- Example: `fn one_of { ([]) { back } (h @ t) { h then one_of(t) } }` - -### Print System -- **Auto-generated**: Print functions created automatically for typedefs (only if no user-defined printer is specified for that type) -- **User-defined**: `print typename(pt, pu, obj)` - takes printer functions for generic types -- **Built-ins**: `puts(string)`, `putc(char)`, `putn(number)`, `putv(value)` -- **Implementation**: Uses currying to specialize generic printers at call sites - -### User-Defined Operators -- **Syntax**: `operator "pattern" [optional ] ` -- **Example**: `operator "_@_" right 90 cons` or `operator "_!" 120 factorial` -- **Patterns**: Use `_` as placeholder for operands in the pattern string - - Prefix: `"-_"` (underscore after operator) - - Infix: `"_+_"` (underscores on both sides) - - Postfix: `"_!"` (underscore before operator) -- **Restrictions**: Can't redefine with same fixity, can't have same op as both infix and postfix -- Defined in `src/preamble.fn` or user code - ## Memory Management -**Mark-and-sweep GC with global protection stack**: +### Mark-and-sweep GC with global protection stack -- Use `PROTECT(obj)` macro to shield objects during construction. -- `PROTECT(obj)` pushes `obj` onto protection stack and returns the previous stack pointer. -- `PROTECT(NULL)` just returns the current stack pointer. -- `UNPROTECT(save)` restores the stack pointer to `save`. +- Use `PROTECT(obj)` macro to shield objects during construction +- `PROTECT(obj)` pushes `obj` onto protection stack and returns the previous stack pointer +- `UNPROTECT(save)` restores the stack pointer to `save` (previous result of `PROTECT()`) - Pattern: `int save = PROTECT(obj); /* allocating code */ UNPROTECT(save);` -- **CRITICAL: Never use literal numbers with UNPROTECT** - The only valid argument to `UNPROTECT(save)` is a value returned by a previous call to `PROTECT()`. Never write `UNPROTECT(0)` or any other literal number. -- All allocated structures have `Header` with GC metadata -- Generated `mark*()` functions handle recursive marking +- Never use literal numbers with UNPROTECT - only values returned by `PROTECT()` + +### HashSymbol objects must never be PROTECT'ed -**CRITICAL: HashSymbol objects must NEVER be PROTECT'ed**: -- `HashSymbol` objects are **not** GC-managed (no `Header`) +- `HashSymbol` objects are not GC-managed (no `Header`) - Symbols are automatically interned in a global symbol table and never freed -- Calling `PROTECT(hashSymbol)` will corrupt the protection stack and cause GC errors -- This includes symbols returned by: `newSymbol()`, `genSym()`, `genSymDollar()`, token types, etc. -- Only protect structures with a `Header` (AST nodes, arrays, hashes, etc.) +- Calling `PROTECT(hashSymbol)` will corrupt the protection stack ## C Coding Conventions -**Generated union constructor functions**: +### Generated union constructor functions + - `new_(parserInfo, variant)` - Wraps an existing variant in a union - - Use when you already have the variant object and just need to create the union wrapper - - Example: `newLamExp_Amb(parserInfo, ambNode)` - `make_(parserInfo, field1, field2, ...)` - Constructs variant then wraps in union - - Use when you have the raw field values and need to construct both variant and union - - Example: `makeLamExp_Amb(parserInfo, exp1, exp2)` -- **Important**: Visitor patterns should use `new*` functions since they already have visited variants - -**Type-safe union accessors**: -- `get_(union*)` - Safely extracts variant from union with type checking - - Example: `LamAmb *amb = getLamExp_Amb(node)` - - In production builds: compiles to direct field access `node->val.amb` - - In debug builds: validates the union type matches expected variant - - **Prefer this over direct field access** (`node->val.amb`) for safety - -**ParserInfo access**: -- `CPI(node)` - Macro to access node's parser info - - Expands to `node->_yy_parser_info` - - **Always use this macro** instead of direct field access - - Provides indirection in case the field name or access pattern changes - -**Pointer comparisons**: -- **Always use explicit NULL comparisons**: `if (ptr != NULL)` or `if (ptr == NULL)` -- **Never test pointer "truthiness"**: Don't use `if (ptr)` or `if (!ptr)` -- Makes intent clearer and avoids potential confusion with boolean expressions -- Example: Write `if (node->next != NULL)` not `if (node->next)` - -**Naming Conventions**: -- Types: `MixedCase` (e.g., `LamExp`, `AstExpression`) -- Functions and Variables: `camelCase` (e.g., `cpsTcLamExp`, `newLamExp_Amb`) -- Avoid snake case, underscores are reseved for special uses (e.g. union discriminators) - -## Documentation Style - -**Avoid hyperbole and excessive emphasis**: -- Use simple periods instead of exclamation points in technical documentation -- Avoid phrases like "HUGE WIN", "Amazing", "Incredible" - use "significant", "notable", "substantial" -- Avoid emphatic modifiers like "Critical", "Key", "Major" in headings - use plain descriptive headings -- Avoid verdict-style declarations like "Verdict:", "Key insight:", "Key advantage:" - state facts directly -- Remove emoji decorations from section headings (🎉, 💡, ✅, etc.) -- Avoid unnecessary all-caps emphasis (IMPORTANT, MUST, NEVER) except in actual code constants or where technically required -- Minimize bold emphasis on routine statements - reserve for truly important concepts -- Keep tone professional and measured -- State facts directly without emphatic language -- Example: Write "This improves performance." not "This improves performance!" -- Example: Write "Significant code reduction." not "HUGE code reduction!" -- Example: Write "## Generated Visitor Pattern" not "## Critical Discovery: Generated Visitor Pattern" -- Example: Write "Problem/Mitigation" not "Risk/Mitigation" for straightforward issue discussion - -**Markdown formatting**: -- Follow linting rules from markdownlint extension: https://github.com/DavidAnson/markdownlint/blob/v0.40.0/doc/Rules.md -- Use consistent heading styles, proper list formatting, and appropriate spacing -- Ensure code blocks have language identifiers -- Avoid trailing spaces and ensure proper line endings - -## Debugging - -**Conditional compilation flags** (define in source to enable): -- `DEBUG_STEP`, `DEBUG_BYTECODE`, `DEBUG_TC`, `DEBUG_LAMBDA_CONVERT`, etc. -- Defined in `src/common.h` -- Each stage has `#include "debugging_on.h"` or `"debugging_off.h"` pattern -- Command-line: `--dump-ast`, `--dump-lambda`, `--dump-anf`, `--dump-bytecode` - -## Type System - -- **Hindley-Milner** type inference with parametric polymorphism -- Implementation in `src/tc_analyze.c` uses logical variables (not substitutions) -- See `docs/TYPES.md` for the journey (final approach differs from notes!) -- Type checking happens **between** lambda conversion and ANF - -## Testing - -- **C Unit Tests**: `tests/src/*.c` (enabled with `MODE=unit`) -- **Language Tests**: `tests/fn/test_*.fn` run with `--assertions-accumulate` -- Tests automatically run via `make test` - -## Pratt Parser & Syntactic Extension - -**Table-driven parser enabling runtime operator definitions** - The Pratt parser allows F♮ to be syntactically extensible, supporting user-defined operators with custom precedence and associativity. Operators are defined using a unified `operator` keyword with mixfix patterns (e.g., `"_+_"` for infix, `"-_"` for prefix, `"_!"` for postfix) rather than separate `prefix`/`infix`/`postfix` keywords. - -**Note**: The Pratt parser implementation (and much of the early memory management and hash table code) is based on Bob Nystrom's excellent book [Crafting Interpreters](https://craftinginterpreters.com/). - -### Why Pratt Parsing? - -Traditional parser generators (Flex/Bison) compile to fixed runtime parsers, making syntactic extension impossible. F♮ uses a **hand-written Pratt parser** that is: -- **Table-driven**: All precedence/associativity handled by runtime tables (`PrattRecordTable`) -- **Re-entrant**: Can pause parsing, load linked files, resume (required for `link` directive) -- **Scoped**: Operator definitions are scoped to `let/in` blocks and `{ }` nests -- **UTF-8 aware**: Token scanner uses tree structures called "tries" to efficiently recognize Unicode operators (a trie is a tree where each path from root to leaf represents a token, indexed by successive characters) - -### Architecture Overview - -**Three main components**: - -1. **Scanner** (`src/pratt_scanner.c`): - - Trie-based token recognition (`PrattTrie`) - - Handles keywords, operators, strings, numbers, characters - - Maintains input stack (`PrattBufList`) for nested file parsing - - Produces token stream (`PrattToken`) - -2. **Parser** (`src/pratt_parser.c`): - - Core function: `expressionPrecedence(parser, precedence)` - - Looks up operators in `PrattRecordTable` by symbol - - Each `PrattRecord` contains prefix/infix/postfix implementations - - Parselets are function pointers: `typedef AstExpression *(*PrattParselet)(PrattRecord *, PrattParser *, AstExpression *, PrattToken *)` - -3. **Parser State** (`PrattParser`): - - `rules`: Hash table of operator parsing rules - - `trie`: Token recognition trie - - `lexer`: Scanner state - - `next`: Pointer to parent parser (for scope nesting) - -### Precedence & Associativity - -**Precedence scaling** (`PRECEDENCE_SCALE = 3`): -- User declares precedence (e.g., `100`) -- Internal precedence: `user_prec * 3` -- Allows +1/-1 adjustments without overlapping: `(1*3+1) < (2*3-1)` - -**Associativity** (stored in `PrattRecord`): -- **Left**: RHS parsed with `prec + 1` (tighter binding right) -- **Right**: RHS parsed with `prec - 1` (allows right recursion) -- **None**: RHS parsed with `prec` (disallows chaining) - -Example from `src/preamble.fn`: -```fn -operator "_+_" left 10 ADDITION; // left associative: a + b + c = (a + b) + c -operator "_@_" right 90 cons; // right associative: a @ b @ c = a @ (b @ c) -operator "_<=>_" none 5 COMPARISON; // non-associative: can't chain a <=> b <=> c -``` - -### Operator Definition Syntax - -**Syntax**: `operator "pattern" [associativity] precedence implementation` - -**Examples**: -```fn -operator "-_" 13 negate; // prefix unary -operator "_+_" left 100 addition; // infix binary left-assoc -operator "_then_" right 2 amb; // infix binary right-assoc -operator "_?" 120 optional; // postfix unary (hypothetical) -``` - -**Macros as operators**: -```fn -macro AND(a, b) { if (a) { b } else { false } } -operator "_and_" left 3 AND; -``` -Macro arguments are wrapped in thunks (`fn() { arg }`) and lazily evaluated, providing proper scoping. - -### Parser Table (`PrattRecord`) - -Each operator symbol maps to a `PrattRecord` containing: - -```c -struct PrattRecord { - HashSymbol *symbol; // Operator symbol - PrattParselet prefixOp; // Prefix parser function (or NULL) - int prefixPrec; // Prefix precedence - AstExpression *prefixImpl; // User implementation (or NULL for built-ins) - PrattParselet infixOp; // Infix parser function (or NULL) - int infixPrec; // Infix precedence - AstExpression *infixImpl; // User implementation - PrattParselet postfixOp; // Postfix parser function (or NULL) - int postfixPrec; // Postfix precedence - AstExpression *postfixImpl; // User implementation - PrattAssoc associativity; // LEFT, RIGHT, or NONE -}; -``` - -**Key parselets**: -- `userPrefix()` - Handles user-defined prefix operators -- `userInfixLeft()`, `userInfixRight()`, `userInfixNone()` - Handle infix with associativity -- `userPostfix()` - Handles user-defined postfix operators -- Built-in parselets: `grouping()`, `list()`, `fn()`, `iff()`, `switchExp()`, etc. - -### Scoping Mechanism - -**Parser nesting**: Each `PrattParser` has a `next` pointer to parent parser. When entering a new scope: -1. Create new `PrattParser` with `next` pointing to parent -2. Copy parent's `rules` table (copy-on-write semantics) -3. Parse scope body -4. Discard child parser when exiting scope - -**Scope entry points**: -- `let ... in ...` blocks -- `{ }` nests -- File boundaries (via `link` directive) -- Namespace imports - -**Operator shadowing**: Inner scopes can redefine operators; definitions are forgotten when scope exits. - -### Exporting and importing operators - -F♮ supports exporting operators from a namespace and importing them into other scopes, while preserving hygiene and lexical scoping. - -- Export operators in a namespace: - - `export operators;` to export all operators defined in that namespace - - Or export during definition by prepending the keyword `export` to the operator definition: - - `export operator "_+_" left 100 addition;` -- Import exported operators (after `link "file.fn" as ns;`): - - `import ns operators;` to import all exported operators - - Or per-operator: `import ns operator "~_";`, `import ns operator "_plus_";`, `import ns operator "_squared";` - -Conflicts: redefining the same symbol+fixity in the same scope is an error; importing a different fixity for an existing symbol is an error. Shadowing is allowed by redefining/importing in an inner `let`. - -Hygiene: imported operator applications call a hygienic wrapper qualified to the defining namespace, so free variables resolve to the definition site and cannot be captured by local bindings in the importing scope. - -### Known Limitations & Improvement Areas - -1. **Restriction: Operator can't be both infix and postfix** - - Comment in code: "operators can't be both infix and postfix" - - Reason: `PrattRecord` allows all three fixities but parser may have conflicts - - Could be relaxed with better disambiguation - -2. **Fixity conflicts**: Same symbol with multiple fixities must be disambiguated - - Current: Simply disallowed - - Improvement: Context-sensitive parsing based on preceding token - -3. (Addressed) Operator export/import from namespaces is implemented as described above. Future improvements: richer conflict diagnostics, and optional re-export controls in aggregate modules. +- Visitor patterns should use `new*` functions since they already have visited variants -4. **Precedence granularity**: `PRECEDENCE_SCALE = 3` limits how many operators can fit between declared levels - - Could be increased if needed +### Type-safe union accessors -5. **Macro hygiene**: Currently solved by wrapping args in thunks - - See `docs/OPERATORS.md` for evolution of approach - - Works but adds runtime overhead (though optimized in simple cases) - -6. **Copy-on-write for rules tables**: Not currently implemented - - Each scope creates full copy of parent's rules - - Could be optimized with COW semantics +- `get_(union*)` - Safely extracts variant from union with type checking +- Prefer this over direct field access (`node->val.amb`) for safety -### Integration with Lambda Conversion +### ParserInfo access -After parsing, operator applications are transformed: -- Infix: `a + b` → `addition(a, b)` (function application) -- Prefix: `!a` → `NOT(a)` -- Postfix: `a!` → `factorial(a)` +- `CPI(node)` - Macro to access node's parser info (expands to `node->_yy_parser_info`) +- Always use this macro instead of direct field access -Macro operators are handled specially: -1. Arguments wrapped in thunks during lambda conversion: `AND(a, b)` → `AND(fn(){a}, fn(){b})` -2. Macro substitution unwraps if thunk just invokes arg: `fn(){a()}` → `a` -3. Free variables in macro body resolved in definition scope (lexical scoping) +### Pointer comparisons -See `src/macro_substitution.c` for implementation details. +- Always use explicit NULL comparisons: `if (ptr != NULL)` or `if (ptr == NULL)` -### Debugging Parser Issues +### Naming Conventions -```bash -# Enable parser debug output -# Uncomment DEBUG_PRATT_PARSER in src/common.h +- Types: `MixedCase` (e.g., `LamExp`, `AstExpression`) +- Functions and Variables: `camelCase` (e.g., `cpsTcLamExp`, `newLamExp_Amb`) +- Avoid snake case; underscores reserved for union discriminators i.e. `newLamExp_Amb`. -# Dump AST to see how operators parsed -./bin/fn --dump-ast path/to/file.fn -``` +## Documentation Style -**Watch for**: -- Precedence conflicts (operators binding wrong way) -- Associativity bugs (wrong grouping in chains) -- Scope leakage (operators visible outside their scope) -- Macro expansion issues (arguments evaluated too early/late) +- 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 -### Key Files +## Debugging -- `src/pratt_parser.c` - Main parser implementation (4300+ lines) -- `src/pratt_scanner.c` - Token scanner with trie-based recognition -- `src/pratt.yaml` - Parser data structures -- `src/preamble.fn` - Required operator definitions (compiler depends on these) -- `docs/PARSING.md` - Original design notes and requirements -- `docs/OPERATORS.md` - Evolution of operator and macro system +### Conditional compilation flags -### Testing +(define in source to enable): -Operator tests in `tests/fn/`: -- Precedence and associativity combinations -- Scope behavior (shadowing, export) -- Macro hygiene and lazy evaluation +- `DEBUG_STEP`, `DEBUG_BYTECODE`, `DEBUG_TC`, `DEBUG_LAMBDA_CONVERT`, etc. +- Defined in `src/common.h` +- Each stage has `#include "debugging_on.h"` or `"debugging_off.h"` pattern -### Future Work +### Command-line flags -Potential improvements for operator system: -- Allow infix/postfix ambiguity (context-sensitive parsing) -- Copy-on-write for parser rule tables (performance) -- Better precedence conflict detection at definition time +- `--dump-ast`, `--dump-lambda`, `--dump-anf`, `--dump-bytecode` etc. +- `--exec=""` to run code snippet directly +- `--stress-gc` forces GC on every allocation +- `--help` shows all. ## Common Patterns -**Adding a new bytecode instruction**: +### Adding a new bytecode instruction + 1. Add to `src/cekfs.yaml` enum 2. Implement in `src/step.c` switch statement 3. Add compiler case in `src/bytecode.c` 4. Update `docs/bytecodes.md` documentation -**Adding a new AST node type**: +### Adding a new AST node type + 1. Define in appropriate `.yaml` file (ast/lambda/anf/etc) 2. Run `make` to regenerate code 3. Add handling in conversion functions for next stage 4. Add pretty-printing in `*_pp.c` if needed -**Lexical addressing**: Variables stored as `(frame, offset)` pairs after static analysis. Never use variable names at runtime. - ## File Organization - `src/` - C source and YAML schemas @@ -575,222 +143,42 @@ Potential improvements for operator system: - `fn/` - Standard library and example programs - `tests/fn/` - Language test suite - `docs/` - Architecture documentation (read `MATH.md`, `V2.md`, `TYPES.md`) +- `docs/agent/` - Detailed stage-specific documentation for AI assistants - `tools/` - Python code generators and utilities -- `unicode/` - Unicode data tables (downloaded on first build) ## Key Invariants -1. **All intermediate representations are immutable** - transformations produce new structures -2. **Type checking must succeed** before proceeding to ANF -3. **Namespaces are compile-time only** - resolved during lambda conversion -4. **The preamble** (`src/preamble.fn`) defines required operators and types - compiler depends on these existing -5. **Variables lose names** after lexical addressing - only frame/offset used at runtime - -## TPMC (Term Pattern Matching Compiler) - -**Critical component that may need improvement** - Compiles pattern-matching function definitions into efficient decision trees. - -### What TPMC Does - -Converts multi-clause pattern-matching functions like: -```fn -fn map { - (_, []) { [] } - (f, h @ t) { f(h) @ map(f, t) } -} -``` - -Into optimized decision trees (DFA-like state machines) that efficiently dispatch based on argument structure. - -### Architecture - -**Four main files** (all in `src/`): -- `tpmc_logic.c` - Entry point, converts AST patterns to TPMC patterns, creates root variables -- `tpmc_match.c` - Core algorithm implementing the Variable Rule and Mixture Rule -- `tpmc_translate.c` - Generates lambda expressions from the compiled state machine -- `tpmc_compare.c` - Handles comparison patterns (e.g., `(x, x @ _)` where same variable appears twice) - -**Supporting files**: -- `tpmc.yaml` - Defines TPMC data structures (states, arcs, patterns, matrices) -- `tpmc_pp.c` - Pretty-printing for debugging -- `tpmc_mermaid.c` - Generates Mermaid diagrams of state machines (use `--dump-tpmc=`) - -### The Algorithm (from Pettersson 1992 paper) - -**Step 1: Pattern Matrix Construction** -- Collects all function clauses into a matrix M where rows = clauses, columns = arguments -- Each pattern gets a unique "path" name (e.g., `p$0`, `p$1`, `p$1$0` for nested) -- Creates array S of final states (function bodies) - -**Step 2: DFA Generation via `match(M, S)`** -- **Variable Rule**: If top row is all wildcards, return first final state (trivial match) -- **Mixture Rule**: Find first column with constructors/comparisons: - 1. For each unique constructor K in that column: - - Extract rows matching K, expand nested patterns - - Recurse on sub-matrix - - Create arc labeled with K - 2. Handle wildcards as fallback arc - 3. Add error arc if not exhaustive - -**Step 3: Optimization** -- Reference-count states -- States with refcount > 1 become local functions (letrec-bound) -- Remove duplicate states - -**Step 4: Code Generation** -- Test states → `switch` expressions (MATCH for constructors, COND for constants) -- Arcs → case arms -- Final states → function bodies with variable bindings in scope - -### Known Issues & Improvement Areas - -1. **Comparison Pattern Ordering**: When a pattern like `(x, x @ _)` appears, the algorithm must ensure `x` is bound before comparison. Current fix: prefer first column if any pattern exists in top row. May not be optimal. - -2. **Nested Pattern Efficiency**: Deep nesting can produce many intermediate states. Consider flattening optimizations. - -3. **Exhaustiveness Checking**: The language enforces exhaustive pattern matching via the `unsafe` qualifier. Functions with non-exhaustive patterns MUST be declared `unsafe fn ...`, and functions with exhaustive patterns CANNOT be declared unsafe. The compiler enforces both rules. See `fn/listutils.fn` for examples like `unsafe fn foldl1 (func, h @ t)` which only handles non-empty lists. - -4. **Matrix Column Selection**: The "find first constructor column" heuristic is simple but may not produce minimal DFAs. Could benefit from cost-based selection. - -5. **Path Naming**: Generated names like `p$1$2$0` work but are hard to debug. Better naming strategy? - -### Debugging TPMC - -```bash -# Generate Mermaid diagram of compiled pattern match -./bin/fn --dump-tpmc=functionName path/to/file.fn > diagram.md - -# Enable debug output during compilation -# Uncomment DEBUG_TPMC_MATCH in src/common.h -``` - -**Watch for**: -- "unsafe function" warnings (comparisons without proper binding) -- Non-exhaustive pattern matches (may indicate missing cases) -- Large state machines (>20 states suggests optimization opportunity) - -### Key Data Structures - -- `TpmcMatrix` - 2D array of patterns (width=args, height=clauses) -- `TpmcState` - Either test state (with arcs) or final state (with body) -- `TpmcArc` - Transition labeled with pattern (constructor/comparison/wildcard) -- `TpmcPattern` - Wildcard, Var, Constructor, Comparison, Character, BigInt, Assignment - -### Testing - -Pattern matching tests in `tests/fn/test_*.fn` - especially: -- `test_tc.fn` - Complex mutual recursion with patterns -- `fn/barrels.fn` - Non-deterministic search with patterns -- `fn/listutils.fn` - Standard list operations - -## ANF (A-Normal Form) Conversion - -**May be overly complex and error-prone** - Converts lambda expressions to A-Normal Form where all intermediate computations are named. - -### What ANF Does - -Transforms nested expressions into a flat sequence of let-bindings where: -- **Atomic expressions (aexp)**: Variables, constants, lambdas - always terminate, never error -- **Complex expressions (cexp)**: Function applications, conditionals - may not terminate or may error -- All complex subexpressions become let-bound temporary variables - -Example transformation: -```scheme -(a (b c) (d e)) -=> -(let (t$1 (d e)) - (let (t$2 (b c)) - (a t$2 t$1))) -``` - -### The Algorithm (from Matt Might's blog) - -**Core Idea**: Walk expressions depth-first, replacing complex subexpressions with fresh variables, accumulating let-bindings on the way back out. - -**Key functions** (all in `src/anf_normalize.c`): -- `normalize(LamExp, tail)` - Main entry point, dispatches on LamExp type -- `replaceLamExp(LamExp, replacements)` - Converts LamExp to Aexp, accumulating replacements -- `letBind(body, replacements)` - Wraps body in let-bindings from replacements table -- `wrapTail(exp, tail)` - Optionally wraps expression in additional let-binding - -**The `tail` parameter**: Continuation-like - represents the "rest of the computation" to wrap the current expression in. NULL means this is the final result. - -### Implementation Pattern - -Most normalize functions follow this pattern: -1. Create a `LamExpTable` for tracking replacements (hash table mapping fresh symbols to LamExps) -2. Call `replaceLamExp()` on subexpressions, which: - - If subexpr is atomic (var/constant), return it as Aexp - - If subexpr is complex (application), generate fresh symbol, add to replacements, return symbol as Aexp -3. Build the ANF construct with replaced Aexps -4. Call `wrapTail(exp, tail)` to optionally wrap in outer binding -5. Call `letBind(exp, replacements)` to wrap in all accumulated let-bindings -6. Return the wrapped expression - -### Critical Data Flow + 1. Intermediate representations are typically (not always) immutable - transformations produce new structures + 2. Type checking must succeed before proceeding to ANF + 3. Namespaces are compile-time only - resolved during lambda conversion + 4. The preamble (`src/preamble.fn`) defines required operators and types - compiler depends on these + 5. Variables lose names after lexical addressing - only frame/offset used at runtime -``` -LamExp (lambda.yaml) - ↓ normalize() - → replaceLamExp() + LamExpTable - → Aexp (atomic expressions) - → Build ANF structure (Exp/Cexp) - → wrapTail() - → letBind() - wraps in let-bindings - ↓ -Exp (anf.yaml) -``` - -### Known Complexity Issues - -1. **Deeply Nested Functions**: The normalize functions have 30+ dispatch cases, one per LamExp type. Each follows slightly different logic. - -2. **GC Protection Overhead**: Extensive use of PROTECT/UNPROTECT macros throughout due to allocations during traversal. Easy to get wrong. - -3. **Tail Threading**: The `tail` parameter threads through recursion but its purpose isn't always clear. Sometimes NULL, sometimes accumulated let-bindings. - -4. **Dual Type System**: Must track both LamExp (input) and Aexp/Cexp/Exp (output) simultaneously. Easy to confuse which type is which. - -5. **Replacements Table**: The `LamExpTable` accumulates symbol→LamExp mappings that become let-bindings, but lifetime and scope isn't always obvious. - -### Debugging ANF - -```bash -# Enable debug output -# Uncomment DEBUG_ANF in src/common.h - -# Dump ANF for inspection -./bin/fn --dump-anf path/to/file.fn -``` - -**Watch for**: -- Incorrect nesting of let-bindings -- Fresh symbol collisions (shouldn't happen but indicates `freshSymbol()` issues) -- GC crashes (usually from missing PROTECT/UNPROTECT) -- Type mismatches between LamExp and ANF structures +## Testing -### Potential Improvements +- **C Unit Tests**: `tests/src/*.c` - alternative `main()` functions. +- **Language Tests**: `tests/fn/test_*.fn` run with `--assertions-accumulate` +- Tests automatically run via `make test` -1. **Simplify normalize dispatch**: Could the 30+ cases share more common code? -2. **Clearer tail semantics**: Document when tail is NULL vs. non-NULL -3. **Reduce PROTECT overhead**: Could intermediate allocations be batched? -4. **Better error messages**: When ANF conversion fails, why? -5. **Refactor replacements**: The hash table approach works but is it the clearest? +## Stage-Specific Documentation -### Key Files +For detailed information on specific compiler stages, see: -- `src/anf_normalize.c` - The implementation (1100+ lines) -- `src/anf.yaml` - ANF data structures (Exp, Aexp, Cexp) -- `src/lambda.yaml` - Input lambda structures -- `docs/ANF.md` - Original algorithm notes -- Reference: [Matt Might's ANF blog post](https://matt.might.net/articles/a-normalization/) +- [code-generation.md](../docs/agent/code-generation.md) - YAML schemas and generated code +- [pratt-parser.md](../docs/agent/pratt-parser.md) - Parser, operators, syntactic extension +- [tpmc.md](../docs/agent/tpmc.md) - Pattern matching compilation +- [anf.md](../docs/agent/anf.md) - A-Normal Form conversion +- [language-syntax.md](../docs/agent/language-syntax.md) - F♮ language reference ## When Reading Code - Start at `src/main.c` for overall flow - Each stage has `*_helper.h` with utility functions -- Generated `*_debug.c` files are essential for understanding structure relationships -- `docs/MATH.md` formalizes the CEKF machine mathematics -- `docs/lambda-conversion.md` has extensive TPMC algorithm walkthrough with examples -- `docs/pettersson92.pdf` - The original Pettersson 1992 paper on pattern matching compilation -- Pratt parsing is unusual - see `src/pratt_parser.c` for infix operator handling +- Generated `*_debug.c` files contain basic pretty-printers for data structures +- `docs/lambda-conversion.md` has extensive TPMC algorithm walkthrough + +## Workflows and Cross-Cutting Concerns + +See [workflows.md](../docs/agent/workflows.md) for detailed guides on: +- Error Handling (User vs Internal errors) +- Adding Built-in Functions diff --git a/Makefile b/Makefile index 80cc4ee5..435a65d2 100644 --- a/Makefile +++ b/Makefile @@ -252,7 +252,7 @@ $(TEST_DEP): $(DEPDIR)/%.d: $(TSTDIR)/src/%.c .generated | $(DEPDIR) test: $(TEST_TARGETS) $(TARGET) $(UNIDIR)/unicode.db for t in $(TSTDIR)/fn/test_*.fn ; do echo '***' $$t '***' ; ./$(TARGET) --include=fn --assertions-accumulate $$t || exit 1 ; done - for t in $(TSTDIR)/fn/fail_*.fn ; do echo '***' $$t '(expect to see an error) ***' ; ! ./$(TARGET) --include=fn --assertions-accumulate $$t || exit 1 ; done + for t in $(TSTDIR)/fn/fail_*.fn ; do echo '***' $$t '***' ; ! ./$(TARGET) --include=fn --assertions-accumulate $$t >/dev/null 2>&1 || exit 1 ; done for t in $(TEST_TARGETS) ; do echo '***' $$t '***' ; $$t || exit 1 ; done @echo "All tests passed." diff --git a/README.md b/README.md index e94c7c16..3a28d061 100644 --- a/README.md +++ b/README.md @@ -84,7 +84,7 @@ oi --> scanner parser --> ast(AST) --> lc([Lambda Conversion]):::process --> tpmc([Pattern Matching Compiler]):::process lc <---> pg([Print Function Generator]):::process -lc <---> me([Macro Expansion]):::process +lc <---> me([Lazy Function Expansion]):::process tpmc --> vs([Variable Substitution]):::process vs --> lc lc <--> des([Desugaring]):::process @@ -97,7 +97,9 @@ tc --> lambda2(Plain Lambda Form) lambda2 --> ci([Constructor Inlining]):::process ci --> lambda3(Inlined Lambda) subgraph anf-rewrite-2 - alpha(["ɑ-Conversion"]):::process + desugaring(["Desugaring"]):::process + desugaring --> lambda_ds(desugared lambda) + lambda_ds --> alpha(["ɑ-Conversion"]):::process alpha --> lambda_a(alphatized lambda) lambda_a --> anfr([ANF Rewrite]):::process anfr --> lambda_b(New ANF) @@ -109,7 +111,7 @@ subgraph anf-rewrite-2 lambda_c --> betar(["β-Reduction WiP"]):::process betar --> lambda_d(simplified) end -lambda3 --> alpha +lambda3 --> desugaring lambda3 --> anfc lambda_a --> anfc([A-Normal Form Conversion]):::process anfc --> anf(ANF) @@ -124,6 +126,7 @@ bc --> cekf([CEKF Runtime VM]):::process The "anf-rewrite-2" section is a WiP on the `anf-rewrite-2` branch. Although that branch started as a rewrite of the ANF transform, it became apparent that the CEK machine itself was blocking optimizations and so the intention is to target a more "traditional" register machine with an eye towards LLVM in the longer term. On that branch the ɑ-conversion is complete and incorporated (though it achieves nothing for the ANF path it is required for CPS.) The ANF rewrite is complete but abandoned, and the CPS transform is also complete. The various components named in the diagram above are linked to their implementation entry point here: + * Scanner [pratt_scanner.c](src/pratt_scanner.c) * Parser [pratt_parser.c](src/pratt_parser.c) * AST [ast.yaml](src/ast.yaml) @@ -131,7 +134,7 @@ The various components named in the diagram above are linked to their implementa * Tpmc [tpmc_logic.c](src/tpmc_logic.c) * Print Function Generator [print_generator.c](src/print_generator.c) * Variable Substitution [lambda_substitution.c](src/lambda_substitution.c) -* Macro Expansion [macro_substitution.c](src/macro_substitution.c) +* Lazy Function Expansion [lazy_substitution.c](src/lazy_substitution.c) * Plain Lambda Form [lambda.yaml](src/lambda.yaml) * Simplification [lambda_simplify.c](src/lambda_simplify.c) * Type Checking [tc_analyze.c](src/tc_analyze.c) diff --git a/docs/BETTER-EXTERNAL.md b/docs/BETTER-EXTERNAL.md new file mode 100644 index 00000000..33f7b417 --- /dev/null +++ b/docs/BETTER-EXTERNAL.md @@ -0,0 +1,41 @@ +# Proposal for Replacing the `external` Section in Yaml Files + +Currenty, and embarrassingly, the `external` section in the yaml files is just a synonym for the `primitives` section. The intention of the `external` section was to describe specifically memory-managed types from other yaml files, but that requires adding information that is already available from those files. + +The idea then is quite simple: rather than the `external` section listing details of those other types: + +```yaml +external: + TcType: + meta: + brief: external type from the type-checker + description: A type-checker type referenced by the ANF code. + data: + cname: "struct TcType *" + printFn: printTcType + markFn: markTcType + valued: true + IntMap: + meta: + ... +``` + +it would just contain references to the files themselves: + +```yaml +external: +- !include tc.yaml +``` + +Those includes could be parsed recursively by the existing parser and added to the current catalog. +This causes a couple of problems, but they should be easy enough to solve: + +1. How to avoid generating code for the external nodes? Each entry in the catalog has an additional `external` flag, if true it is skipped over by the catalog dispatchers. +2. How to avoid mutually recursive includes? The `include` feature of the yaml is written in `generate/loader.py` and that code could be extended to quietly return an empty object if it sees a file it has already (started to) load. +3. How to avoid primitives being re-entered and causing duplicates? Actually the same solution for recursive includes, `primitives.yaml` would only be parsed once. + +I'd imagine that the entire parse and catalog-injection section in `generate.py` would become a function that gets handed an object resulting from a yaml file, along with an `external` boolean flag. It would call itself recursively with each element of any `internal` section that it finds. + +The `config` section could be ignored or only partially used if it is `external`. + +Of course there wil likely be other problems, probably `#include` directives will need looking at, but the advantages of having direct access to the original definitions is obvious. diff --git a/docs/OPERATORS.md b/docs/OPERATORS.md index b7b76ead..c5cc74d5 100644 --- a/docs/OPERATORS.md +++ b/docs/OPERATORS.md @@ -1,5 +1,9 @@ # Operators (and macros) +Important update if you are reading this: the keyword `macro` has since been +replaced with the sequence `lazy fn` in the parser to better reflect its +nature. However the semantics are unchanged. + Some issues with the initial implementation. I'd thought I could get away with a pure parser-only implementation of diff --git a/docs/TODO.md b/docs/TODO.md index 8d58400f..91b46a31 100644 --- a/docs/TODO.md +++ b/docs/TODO.md @@ -2,8 +2,15 @@ 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. +* Clean Up. + * Generate + * Move all signatures into `signature_helper.py`, not just the shared ones. * More numbers: * NaN for division by Zero etc. * Matrices. @@ -29,4 +36,3 @@ More of a wish-list than a hard and fast plan. * (internal) have a NEWZ variant of NEW that bzero's its result. * Builtins * `now()` builtin returns current time in milliseconds. - * `iter()` returns consecutive integers starting from 0 diff --git a/docs/agent/anf.md b/docs/agent/anf.md new file mode 100644 index 00000000..cacf4138 --- /dev/null +++ b/docs/agent/anf.md @@ -0,0 +1,138 @@ +# ANF (Administrative Normal Form) Conversion + +Converts lambda expressions to A-Normal Form where all intermediate computations are named. + +## What ANF Does + +Transforms nested expressions into a flat sequence of let-bindings where: + +- **Atomic expressions (aexp)**: Variables, constants, lambdas - always terminate, never error +- **Complex expressions (cexp)**: Function applications, conditionals - may not terminate or may error +- All complex subexpressions become let-bound temporary variables + +Example transformation: + +```scheme +(a (b c) (d e)) +=> +(let (t$1 (d e)) + (let (t$2 (b c)) + (a t$2 t$1))) +``` + +## The Algorithm (from Matt Might's blog) + +**Core Idea**: Walk expressions depth-first, replacing complex subexpressions with fresh variables, accumulating let-bindings on the way back out. + +**Key functions** (all in `src/anf_normalize.c`): + +- `normalize(LamExp, tail)` - Main entry point, dispatches on LamExp type +- `replaceLamExp(LamExp, replacements)` - Converts LamExp to Aexp, accumulating replacements +- `letBind(body, replacements)` - Wraps body in let-bindings from replacements table +- `wrapTail(exp, tail)` - Optionally wraps expression in additional let-binding + +**The `tail` parameter**: Continuation-like - represents the "rest of the computation" to wrap the current expression in. NULL means this is the final result. + +## Implementation Pattern + +Most normalize functions follow this pattern: + +1. Create a `LamExpTable` for tracking replacements (hash table mapping fresh symbols to LamExps) +2. Call `replaceLamExp()` on subexpressions, which: + - If subexpr is atomic (var/constant), return it as Aexp + - If subexpr is complex (application), generate fresh symbol, add to replacements, return symbol as Aexp +3. Build the ANF construct with replaced Aexps +4. Call `wrapTail(exp, tail)` to optionally wrap in outer binding +5. Call `letBind(exp, replacements)` to wrap in all accumulated let-bindings +6. Return the wrapped expression + +## Critical Data Flow + +```text +LamExp (lambda.yaml) + ↓ normalize() + → replaceLamExp() + LamExpTable + → Aexp (atomic expressions) + → Build ANF structure (Exp/Cexp) + → wrapTail() + → letBind() - wraps in let-bindings + ↓ +Exp (anf.yaml) +``` + +## Known Complexity Issues + +1. **Deeply Nested Functions**: The normalize functions have 30+ dispatch cases, one per LamExp type. Each follows slightly different logic. + +2. **GC Protection Overhead**: Extensive use of PROTECT/UNPROTECT macros throughout due to allocations during traversal. Easy to get wrong. + +3. **Tail Threading**: The `tail` parameter threads through recursion but its purpose isn't always clear. Sometimes NULL, sometimes accumulated let-bindings. + +4. **Dual Type System**: Must track both LamExp (input) and Aexp/Cexp/Exp (output) simultaneously. Easy to confuse which type is which. + +5. **Replacements Table**: The `LamExpTable` accumulates symbol→LamExp mappings that become let-bindings, but lifetime and scope isn't always obvious. + +## Debugging ANF + +```bash +# Enable debug output +# Uncomment DEBUG_ANF in src/common.h + +# Dump ANF for inspection +./bin/fn --dump-anf path/to/file.fn +``` + +**Watch for**: + +- Incorrect nesting of let-bindings +- Fresh symbol collisions (shouldn't happen but indicates `freshSymbol()` issues) +- GC crashes (usually from missing PROTECT/UNPROTECT) +- Type mismatches between LamExp and ANF structures + +## Potential Improvements + +1. **Simplify normalize dispatch**: Could the 30+ cases share more common code? +2. **Clearer tail semantics**: Document when tail is NULL vs. non-NULL +3. **Reduce PROTECT overhead**: Could intermediate allocations be batched? +4. **Better error messages**: When ANF conversion fails, why? +5. **Refactor replacements**: The hash table approach works but is it the clearest? + +## Key Files + +- `src/anf_normalize.c` - The implementation (1100+ lines) +- `src/anf.yaml` - ANF data structures (Exp, Aexp, Cexp) +- `src/lambda.yaml` - Input lambda structures +- `docs/ANF.md` - Original algorithm notes + +## References + +- [Matt Might's ANF blog post](https://matt.might.net/articles/a-normalization/) + +## Tail Recursion & Wrapping Pitfalls + +**Correct tail wrapping is critical**. The `tail` parameter in `normalize` functions represents the "continuation" or "context" that the current expression should return to. + +### Incorrect Wrapping (Breaks Tail Recursion) + +Wraps the result `t$1` in a new `let` *after* the recursive call returns, forcing a stack frame. + +```scheme +;; Source: tail_call(x) +;; Bad ANF: +(let (t$1 (tail_call x)) + t$1) +;; This is NOT a tail call! +``` + +### Correct Wrapping (Preserves Tail Recursion) + +If `tail` is passed down correctly, the recursive call becomes the body of the `let` chain. + +```scheme +;; Source: tail_call(x) +;; Good ANF: +(tail_call x) +;; No wrapping, jumps directly +``` + +**Rule of Thumb**: When normalizing a function call, if it is in tail position (i.e., `tail` parameter is NULL or empty identity), **do not bind it to a variable** just to return that variable. Return the `AppExp` (or `Cexp`) directly. diff --git a/docs/agent/code-generation.md b/docs/agent/code-generation.md new file mode 100644 index 00000000..9b754ee2 --- /dev/null +++ b/docs/agent/code-generation.md @@ -0,0 +1,170 @@ +# Code Generation System + +The build depends heavily on Python code generation. **Do not manually edit files in `generated/`**. + +## 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.) + +## YAML Schema Structure + +Each `.yaml` file in `src/` defines structures for a compiler stage: + +```yaml +config: + name: # e.g., "ast", "lambda", "anf", "cekfs" + description: "..." # Purpose of this stage + parserInfo: true # Include ParserInfo (file name and line number) in structs and unions (only) + limited_includes: # Additional headers needed + - bigint.h + +structs: + StructName: + meta: + brief: "Short description" + description: "Detailed description" + parserInfo: false # optionally disable ParserInfo for this struct + data: + fieldName: fieldType + autoInitField: type=initValue # Constructor auto-initializes, not a parameter + +unions: + UnionName: + meta: + data: + variantName: StructName + ... + +enums: # simple C enums + EnumName: + meta: + data: + - type + - type + +arrays: # support basic push/pop/peek etc. + ArrayName: + meta: + data: + dimensions: 2 # default 1, can be 2 + entries: ElementType + +vectors: # simple lightweight fixed-length memory-managed arrays + VectorName: + meta: + data: + entries: ElementType + +stacks: # derivative of arrays, supports frames + StackName: + meta: + data: + entries: ElementType + +hashes: + HashName: + meta: + data: + entries: ValueType +``` + +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. + +## Primitives (`src/primitives.yaml`) + +Common types shared across all stages - referenced via `!include primitives.yaml`: + +- `HashSymbol` - Symbol table entries (always a pointer) +- `int`, `bool`, `char`, `character` - Basic types +- `BigInt`, `MaybeBigInt` - Arbitrary precision integers +- `file_id` - Source file tracking +- Each has `cname`, `printf`/`printFn`, optionally `markFn`, `eqFn` + +## Generated Functions + +For each struct/union, the code generator produces: + +### Memory Management + +- `new()` - Allocator with GC header, takes all fields as args +- `set()` - Field setter with type check +- `copy()` - Deep copy +- `mark()` - Recursive GC marking +- `free()` - Cleanup (called by GC) +- `eq()` - Deep equality + +### Arrays/Stacks/Vectors + +- `new()` - Create with initial capacity +- `push()` - Append element +- `pop()` - Remove last element +- `peek()` - Access element without removing +- `poke()` - Set element at index + +### Hash Tables + +- `new()` - Create hash table +- `get()` - Retrieve value by key +- `set()` - Store value by key +- Iterator functions for traversal + +### Debugging (in `*_debug.{c,h}`) + +- `print()` - Pretty-print for debugging +- `typenameObj()` - String name of type + +### Object Types (in `*_objtypes.h`) + +- Enum of all object types for GC +- Switch case macros for dispatch +- Generic `mark*Obj()`, `free*Obj()`, `typename*Obj()` dispatchers + +## Extended Features for Generated Unions + +- `new_(variant)` creates a union from an existing variant with the correct discriminating tag. +- `make_(fields...)` creates the variant and wraps it in the union in one step. +- `get_(unionPtr)` extracts the variant from the union, throwing an error if the type does not match. +- `set_(unionPtr, variantPtr)` safely sets the union to a new variant, with type checking. + +## Key Classes in `tools/generate/` + +- `Catalog` - Manages all entities in a YAML file, orchestrates generation +- `SimpleStruct`, `DiscriminatedUnion`, `SimpleArray`, `SimpleStack`, `SimpleHash`, `SimpleVector`, `SimpleEnum`, `Primitive` - each in their own module + +## Usage Pattern + +1. **Define structures** in `src/.yaml` +2. **Run make** - triggers `generate.py` for each YAML (via Makefile) +3. **Generated files** appear in `generated/` +4. **Include headers** in your C code: `#include ".h"` +5. **Use generated functions** - no manual memory management code needed + +## Important Notes + +- **ParserInfo**: If `parserInfo: true`, all structs get `ParserInfo I` field for error reporting source file and line number. +- **Auto-initialized fields**: Use `field: type=value` syntax in YAML to have constructor initialize the field automatically rather than requiring it as a parameter +- **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 + +## Adding New Structures + +1. Add to appropriate `src/*.yaml` file +2. Define in `structs:`, `unions:`, `arrays:`, or `hashes:` section +3. Add `meta` documentation (optional but recommended) +4. Run `make` - regeneration is automatic +5. Include generated header in C files that use the new types +6. **For GC-managed types**: If the YAML generates `*_objtypes.h`: + - Include the generated `*_objtypes.h` file in `src/memory.h` + - Add the `*_OBJTYPES()` macro to the `ObjType` enum at the bottom of `memory.h` + - This registers the types with the garbage collector + - Add the `*_OBJTYPE_CASES()` macro to the switch statements in `markObj()`, `freeObj()`, and `typenameObj()` in `src/memory.c` to complete the integration. + +## Debugging Generation + +If generated code looks wrong: + +- Check YAML syntax (especially indentation) +- Verify types are defined (either in same YAML or `primitives.yaml`) +- Look at similar existing definitions as templates +- Run `python3 tools/generate.py src/.yaml h` manually to see errors diff --git a/docs/agent/language-syntax.md b/docs/agent/language-syntax.md new file mode 100644 index 00000000..c0f47a0c --- /dev/null +++ b/docs/agent/language-syntax.md @@ -0,0 +1,113 @@ +# F♮ Language Syntax Reference + +## Core Syntax + +### Functions + +```fn +fn name { (args) { body } } +// or +let name = fn(args) { body } +``` + +### Let/In Blocks + +- `let` introduces mutually recursive definitions (letrec semantics) +- `in` begins the body that uses those definitions +- Can appear at file top-level or inside any `{ }` block +- Without `let`/`in`, blocks are just sequences of expressions +- Nested `let/in` blocks must be enclosed in curly braces: `let x = 1; in { let y = 2; in y + x }` + +### Pattern Matching + +Functions can have multiple cases, switch on arguments: + +- Wildcards: `_` matches anything without binding +- Named structures: `x = h @ t` binds both components and whole +- Pseudo-unification: `(x, x @ _)` requires matching values +- Switch expressions: `switch (expr) { (pattern) { result } }` + +### Typedefs + +```fn +typedef typename(#generic) { constructor1(types) | constructor2 } +``` + +- Generic types use `#` prefix: `#t`, `#a`, `#b` +- Built-in types: `int`, `char`, `bool`, `string` (alias for `list(char)`) +- Named fields: `constructor{ fieldName: type }` +- Typedefs at `namespace` level are global; typedefs inside `let` blocks are scoped to that block + +### Namespaces + +Files start with `namespace` keyword (like `let` without `in` - mutually recursive declarations). + +- `link` directives must appear inside a `let` or `namespace` block, not at top level +- Import via `link ".fn" as ` (inside `let`) +- Reference imported components as `name.component` + +Example: + +```fn +let + link "listutils.fn" as lst; + result = lst.length([1, 2, 3]); +in + result +``` + +## Common Syntax Gotchas + +- **Link placement**: `link` statements must be inside a `let` or `namespace` block, not standalone +- **Nested blocks**: Nested `let/in` require `{ }` around the `let/in` expression +- **Semicolons in let**: Multiple bindings in `let` are separated by semicolons: `let a = 1; b = 2; in a + b` +- **Variable naming**: Identifiers starting with `fn` followed by a digit (like `fn3`, `fn10`) are rejected by the parser - use different names like `func3`, `f3` +- **Division operator**: `/` on integers will produce rationals, not integer quotient +- **Print declarations**: in a `let`, `print typename { ... }` is a declaration, not an invocation - defines custom printer for a type +- **Exhaustive patterns**: Pattern matches must be exhaustive unless function or switch is declared `unsafe` + +## Non-Deterministic Programming (amb) + +- **`then`**: Right-associative binary operator - evaluates LHS, but if backtracked returns RHS +- **`back`**: Triggers backtracking to most recent `then` +- Not just try/catch - can backtrack to any chronologically previous `then` in the history of the process + +Example: + +```fn +fn one_of { ([]) { back } (h @ t) { h then one_of(t) } } +``` + +See `fn/barrels.fn` for a canonical example. + +## Print System + +- **Auto-generated**: Print functions created automatically for typedefs (only if no user-defined printer is specified for that type) +- **User-defined**: `print typename(pt, pu, obj) {...}` - takes printer functions for generic types +- **Built-ins**: `puts(string)`, `putc(char)`, `putn(number)`, `putv(value)` +- **Implementation**: Uses currying to specialize generic printers at call sites + +## User-Defined Operators + +**Syntax**: `operator "pattern" [optional ] ` + +**Patterns**: Use `_` as placeholder for operands in the pattern string: + +- Prefix: `"-_"` (underscore after operator) +- Infix: `"_+_"` (underscores on both sides) +- Postfix: `"_!"` (underscore before operator) + +**Examples**: + +```fn +operator "_@_" right 90 cons; +operator "_!" 120 factorial; +``` + +**Restrictions**: Can't redefine with same fixity, can't have same op as both infix and postfix. + +Defined in `src/preamble.fn` or user code. For details, see [pratt-parser.md](pratt-parser.md). + +## Wiki + +There is an associated [wiki](https://github.com/billhails/CEKF/wiki) that may contain additional useful information. diff --git a/docs/agent/pratt-parser.md b/docs/agent/pratt-parser.md new file mode 100644 index 00000000..32a70bcc --- /dev/null +++ b/docs/agent/pratt-parser.md @@ -0,0 +1,201 @@ +# Pratt Parser & Syntactic Extension + +Table-driven parser enabling runtime operator definitions. The Pratt parser allows F♮ to be syntactically extensible, supporting user-defined operators with custom precedence and associativity. + +Based on Bob Nystrom's [Crafting Interpreters](https://craftinginterpreters.com/). + +## Why Pratt Parsing? + +Traditional parser generators (Flex/Bison) compile to fixed runtime parsers, making syntactic extension impossible. F♮ uses a hand-written Pratt parser that is: + +- **Table-driven**: All precedence/associativity handled by runtime tables (`PrattRecordTable`) +- **Re-entrant**: Can pause parsing, load linked files, resume (required for `link` directive) +- **Scoped**: Operator definitions are scoped to `let/in` blocks and `{ }` nests +- **UTF-8 aware**: Token scanner uses tries to efficiently recognize Unicode operators + +## Architecture Overview + +### Scanner (`src/pratt_scanner.c`) + +- Trie-based token recognition (`PrattTrie`) +- Handles keywords, operators, strings, numbers, characters +- Maintains input stack (`PrattBufList`) for nested file parsing +- Produces token stream (`PrattToken`) +- Operates on a `wchar_t` array of Unicode code points (UTF-32) + +### Parser (`src/pratt_parser.c`) + +- Core function: `expressionPrecedence(parser, precedence)` +- Looks up operators in `PrattRecordTable` by symbol +- Each `PrattRecord` contains prefix/infix/postfix implementations +- Parselets are function pointers: `typedef AstExpression *(*PrattParselet)(PrattRecord *, PrattParser *, AstExpression *, PrattToken *)` + +### Parser State (`PrattParser`) + +- `rules`: Hash table of operator parsing rules +- `trie`: Token recognition trie +- `lexer`: Scanner state +- `next`: Pointer to parent parser (for scope nesting) + +## Precedence & Associativity + +**Precedence scaling** (`PRECEDENCE_SCALE = 3`): + +- User declares precedence (e.g., `100`) +- Internal precedence: `user_prec * 3` +- Allows +1/-1 adjustments without overlapping: `(1*3+1) < (2*3-1)` + +**Associativity** (stored in `PrattRecord`): + +- **Left**: RHS parsed with `prec + 1` (tighter binding right) +- **Right**: RHS parsed with `prec - 1` (allows right recursion) +- **None**: RHS parsed with `prec` (disallows chaining) + +Example from `src/preamble.fn`: + +```fn +operator "_+_" left 10 ADDITION; // left associative: a + b + c = (a + b) + c +operator "_@_" right 90 cons; // right associative: a @ b @ c = a @ (b @ c) +operator "_<=>_" none 5 COMPARISON; // non-associative: can't chain a <=> b <=> c +``` + +## Operator Definition Syntax + +**Syntax**: `operator "pattern" [associativity] precedence implementation` + +**Patterns**: Use `_` as placeholder for operands: + +- Prefix: `"-_"` (underscore after operator) +- Infix: `"_+_"` (underscores on both sides) +- Postfix: `"_!"` (underscore before operator) + +**Examples**: + +```fn +operator "-_" 13 negate; // prefix unary +operator "_+_" left 100 addition; // infix binary left-assoc +operator "_then_" right 2 amb; // infix binary right-assoc +operator "_?" 120 optional; // postfix unary +``` + +**Lazy functions as operators**: + +```fn +lazy fn AND(a, b) { if (a) { b } else { false } } +operator "_and_" left 3 AND; +``` + +Lazy function arguments are wrapped in thunks (`fn() { arg }`) and lazily evaluated, providing proper scoping. + +## Parser Table (`PrattRecord`) + +Each operator symbol maps to a `PrattRecord` containing: + +```c +struct PrattRecord { + HashSymbol *symbol; // Operator symbol + PrattParselet prefixOp; // Prefix parser function (or NULL) + int prefixPrec; // Prefix precedence + AstExpression *prefixImpl; // User implementation (or NULL for built-ins) + PrattParselet infixOp; // Infix parser function (or NULL) + int infixPrec; // Infix precedence + AstExpression *infixImpl; // User implementation + PrattParselet postfixOp; // Postfix parser function (or NULL) + int postfixPrec; // Postfix precedence + AstExpression *postfixImpl; // User implementation + PrattAssoc associativity; // LEFT, RIGHT, or NONE +}; +``` + +**Key parselets**: + +- `userPrefix()` - Handles user-defined prefix operators +- `userInfixLeft()`, `userInfixRight()`, `userInfixNone()` - Handle infix with associativity +- `userPostfix()` - Handles user-defined postfix operators +- Built-in parselets: `grouping()`, `list()`, `fn()`, `iff()`, `switchExp()`, etc. + +## Scoping Mechanism + +**Parser nesting**: Each `PrattParser` has a `next` pointer to parent parser. When entering a new scope: + +1. Create new `PrattParser` with `next` pointing to parent +2. Copy parent's `rules` table (copy-on-write semantics) +3. Parse scope body +4. Discard child parser when exiting scope + +**Scope entry points**: + +- `let ... in ...` blocks +- `{ }` nests +- File boundaries (via `link` directive) +- Namespace imports + +**Operator shadowing**: Inner scopes can redefine operators; definitions are forgotten when scope exits. + +## Exporting and Importing Operators + +F♮ supports exporting operators from a namespace and importing them into other scopes, while preserving hygiene and lexical scoping. + +**Export operators in a namespace**: + +- `export operators;` to export all operators defined in that namespace +- Or export during definition: `export operator "_+_" left 100 addition;` + +**Import exported operators** (after `link "file.fn" as ns;`): + +- `import ns operators;` to import all exported operators +- Or per-operator: `import ns operator "~_";`, `import ns operator "_plus_";` + +**Conflicts**: Redefining the same symbol+fixity in the same scope is an error; importing a different fixity for an existing symbol is an error. Shadowing is allowed by redefining/importing in an inner `let`. + +**Hygiene**: Imported operator applications call a hygienic wrapper qualified to the defining namespace, so free variables resolve to the definition site. + +## Integration with Lambda Conversion + +After parsing, operator applications are transformed: + +- Infix: `a + b` → `addition(a, b)` (function application) +- Prefix: `!a` → `NOT(a)` +- Postfix: `a!` → `factorial(a)` + +Lazy function operators are handled specially: + +1. Arguments wrapped in thunks during lambda conversion: `AND(a, b)` → `AND(fn(){a}, fn(){b})` +2. Lazy function expansion unwraps if thunk just invokes arg: `fn(){a()}` → `a` +3. Free variables in lazy fn body resolved in definition scope (lexical scoping) + +See `src/macro_substitution.c` for implementation details. + +## Known Limitations + +1. **Operator can't be both infix and postfix** - Could be relaxed with better disambiguation +2. **Fixity conflicts** - Same symbol with multiple fixities simply disallowed +3. **Precedence granularity** - `PRECEDENCE_SCALE = 3` limits operators between declared levels +4. **Lazy fn hygiene** - Solved by wrapping args in thunks; works but adds runtime overhead +5. **Copy-on-write for rules tables** - Not currently implemented; each scope creates full copy + +## Debugging Parser Issues + +```bash +# Enable parser debug output +# Uncomment DEBUG_PRATT_PARSER in src/common.h + +# Dump AST to see how operators parsed +./bin/fn --dump-ast path/to/file.fn +``` + +**Watch for**: + +- Precedence conflicts (operators binding wrong way) +- Associativity bugs (wrong grouping in chains) +- Scope leakage (operators visible outside their scope) +- Lazy fn expansion issues (arguments evaluated too early/late) + +## Key Files + +- `src/pratt_parser.c` - Main parser implementation (4300+ lines) +- `src/pratt_scanner.c` - Token scanner with trie-based recognition +- `src/pratt.yaml` - Parser data structures +- `src/preamble.fn` - Required operator definitions (compiler depends on these) +- `docs/PARSING.md` - Original design notes and requirements +- `docs/OPERATORS.md` - Evolution of operator and lazy fn system diff --git a/docs/agent/tpmc.md b/docs/agent/tpmc.md new file mode 100644 index 00000000..808c1d9b --- /dev/null +++ b/docs/agent/tpmc.md @@ -0,0 +1,149 @@ +# TPMC (Term Pattern Matching Compiler) + +Compiles pattern-matching function definitions into efficient decision trees. + +## What TPMC Does + +Converts multi-clause pattern-matching functions like: + +```fn +fn map { + (_, []) { [] } + (f, h @ t) { f(h) @ map(f, t) } +} +``` + +Into optimized decision trees (DFA-like state machines) that efficiently dispatch based on argument structure. + +## Architecture + +**Four main files** (all in `src/`): + +- `tpmc_logic.c` - Entry point, converts AST patterns to TPMC patterns, creates root variables +- `tpmc_match.c` - Core algorithm implementing the Variable Rule and Mixture Rule +- `tpmc_translate.c` - Generates lambda expressions from the compiled state machine +- `tpmc_compare.c` - Handles comparison patterns (e.g., `(x, x @ _)` where same variable appears twice) + +**Supporting files**: + +- `tpmc.yaml` - Defines TPMC data structures (states, arcs, patterns, matrices) +- `tpmc_pp.c` - Pretty-printing for debugging +- `tpmc_mermaid.c` - Generates Mermaid diagrams of state machines (use `--dump-tpmc=`) + +## The Algorithm (from Pettersson 1992 paper) + +### Step 1: Pattern Matrix Construction + +- Collects all function clauses into a matrix M where rows = clauses, columns = arguments +- Each pattern gets a unique "path" name (e.g., `p$0`, `p$1`, `p$1$0` for nested) +- Creates array S of final states (function bodies) + +### Step 2: DFA Generation via `match(M, S)` + +- **Variable Rule**: If top row is all wildcards, return first final state (trivial match) +- **Mixture Rule**: Find first column with constructors/comparisons: + 1. For each unique constructor K in that column: + - Extract rows matching K, expand nested patterns + - Recurse on sub-matrix + - Create arc labeled with K + 2. Handle wildcards as fallback arc + 3. Add error arc if not exhaustive + +### Step 3: Optimization + +- Reference-count states +- States with refcount > 1 become local functions (letrec-bound) +- Remove duplicate states + +### Step 4: Code Generation + +- Test states → `switch` expressions (MATCH for constructors, COND for constants) +- Arcs → case arms +- Final states → function bodies with variable bindings in scope + +## Key Data Structures + +- `TpmcMatrix` - 2D array of patterns (width=args, height=clauses) +- `TpmcState` - Either test state (with arcs) or final state (with body) +- `TpmcArc` - Transition labeled with pattern (constructor/comparison/wildcard) +- `TpmcPattern` - Wildcard, Var, Constructor, Comparison, Character, BigInt, Assignment + +## Known Issues & Improvement Areas + +1. **Comparison Pattern Ordering**: When a pattern like `(x, x @ _)` appears, the algorithm must ensure `x` is bound before comparison. Current fix: prefer first column if any pattern exists in top row. May not be optimal. + +2. **Nested Pattern Efficiency**: Deep nesting can produce many intermediate states. Consider flattening optimizations. + +3. **Exhaustiveness Checking**: The language enforces exhaustive pattern matching via the `unsafe` qualifier. Functions with non-exhaustive patterns must be declared `unsafe fn ...`, and functions with exhaustive patterns cannot be declared unsafe. The compiler enforces both rules. See `fn/listutils.fn` for examples like `unsafe fn foldl1 (func, h @ t)` which only handles non-empty lists. + +4. **Matrix Column Selection**: The "find first constructor column" heuristic is simple but may not produce minimal DFAs. Could benefit from cost-based selection. + +5. **Path Naming**: Generated names like `p$1$2$0` work but are hard to debug. Better naming strategy? + +## Debugging TPMC + +```bash +# Generate Mermaid diagram of compiled pattern match +./bin/fn --dump-tpmc=functionName path/to/file.fn > diagram.md + +# Enable debug output during compilation +# Uncomment DEBUG_TPMC_MATCH in src/common.h +``` + +**Watch for**: + +- "unsafe function" errors (comparisons without proper binding) +- Non-exhaustive pattern matches (may indicate missing cases) +- Large state machines (>20 states suggests optimization opportunity) + +## Testing + +Pattern matching tests in `tests/fn/test_*.fn` - especially: + +- `test_tc.fn` - Complex mutual recursion with patterns +- `fn/barrels.fn` - Non-deterministic search with patterns +- `fn/listutils.fn` - Standard list operations + +## References + +- `docs/lambda-conversion.md` - Extensive TPMC algorithm walkthrough with examples +- `docs/pettersson92.pdf` - The original Pettersson 1992 paper on pattern matching compilation + +## Matrix Visualization Example + +To visualize the transformation, consider a simplified `map` function: + +```fn +fn map { + (_, []) { [] } + (f, h @ t) { f(h) @ map(f, t) } +} +``` + +**Initial Pattern Matrix (Rows=Clauses, Cols=Arguments):** +```text +Row 1: [ _ , [] ] -> Body 1 +Row 2: [ f , h @ t ] -> Body 2 +``` + +**Transformation:** +1. **Variable Rule**: Column 1 has a wildcard (`_`) and a variable (`f`). Since variables match anything, we *could* process this column, but the **Mixture Rule** prefers columns with constructors. +2. **Column Selection**: Column 2 has constructors `[]` (Nil) and `@` (Cons). TPMC selects Column 2. +3. **Splitting**: TPMC creates a switch on Argument 2: + +```text +SWITCH(Arg2) { + CASE Nil: + // Match Row 1 (Arg2 matched [], Arg1 is wildcard) + // Residual Matrix for Case Nil: + // [ _ ] -> Body 1 + // (This eventually simplifies to just executing Body 1) + + CASE Cons(h, t): + // Match Row 2 (Arg2 matched h@t, Arg1 is f) + // Residual Matrix for Case Cons: + // [ f ] -> Body 2 (with h, t bound) +} +``` + +This matrix reduction process repeats recursively until leaves (Bodies) are reached. diff --git a/docs/agent/workflows.md b/docs/agent/workflows.md new file mode 100644 index 00000000..2e2ea51a --- /dev/null +++ b/docs/agent/workflows.md @@ -0,0 +1,71 @@ +# Workflows and Cross-Cutting Concerns + +This document describes how to implement features that require changes across multiple compiler stages. + +## Error Handling + +The compiler uses two distinct mechanisms for reporting errors depending on their nature: + +1. **User Errors** (`can_happen`): + * Triggered by incorrect user input (syntax errors, type errors). + * **Signature**: `void can_happen(ParserInfo I, const char *message, ...)` + * **Usage**: + * With location: `can_happen(I, "error message", args...)` or `can_happen(CPI(struct), "error message", args...)` + * Without location: `can_happen(NULLPI, "error message", args...)` where NULLPI is a macro for when ParserInfo is not available. + * **Behavior**: These functions do not abort. They print an error message with source location (if ParserInfo.lineNo != 0), set a global `errors` flag, then return to the caller. + * **Location formatting**: Automatically adds " at +{lineNo} {fileName}" if lineNo is non-zero + * **IMPORTANT**: Since execution continues, the calling code MUST return a valid (dummy) value to prevent crashing the current stage. The pipeline will check the `errors` flag after the stage completes and `exit(1)` if set. + * **NULLPI macro**: Defined in common.h as `((ParserInfo){.lineNo = 0, .fileName = NULL})` for contexts where location info is unavailable (e.g., type unification) + +2. **Internal Compiler Errors** (`cant_happen`): + * Triggered by logic bugs in the compiler itself (e.g., reaching a "dead" switch case). + * **Signature**: `void cant_happen(const char *message, ...)` + * Behavior: Prints the message with the file/line of the C source and calls `abort()` (if `DEBUG_DUMP_CORE` is on) or `exit(1)`. + +## Utilities + +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. + +## Adding a Built-in Function + +To add a new native function callable from F♮ code: + +1. **Implement in C**: Add the implementation to `src/builtins_impl.c`. + + ```c + // src/builtins_impl.c + Value *builtin_myFunction(Value **args) { + Value *v1 = args[0]; + // ... implementation ... + return result; + } + ``` + + *Note*: Runtime arguments are `Value*` (from `src/cekfs.yaml`). Use helper macros/functions to unbox integers, strings, etc. + +2. **Declare the Implementation**: Add the declaration in `src/builtins_impl.h`. + + ```c + Value builtin_MyFunction(Vec *args); + ``` + +3. **Create and invoke Registration Helper**: add the helper to `src/builtins_helper.c` and call it. + + ```c + static void registerMyFunction(BuiltIns *registry); + + // in registerBuiltIns() + ... + registerMyFunction(res); + ... + + static void registerMyFunction(BuiltIns *registry) { + BuiltInArgs *args = newBuiltInArgs(); + int save = PROTECT(args); + TcType *integer = newTcType_BigInteger(); // or other return type as appropriate + PROTECT(integer); + pushCharacterArg(args); // or other argument type or types as appropriate + pushNewBuiltIn(registry, "myfunction", integer, args, (void *)builtin_myFunction); + UNPROTECT(save); + } + ``` diff --git a/docs/bespoke-equality.md b/docs/bespoke-equality.md new file mode 100644 index 00000000..c4aeaf04 --- /dev/null +++ b/docs/bespoke-equality.md @@ -0,0 +1,295 @@ +# Bespoke Equality Functions for User Types + +## Status + +Done. + +## Motivation + +Example type that prompted the idea: + +```fn +typedef term { + num(number) | + var(string) | + add(term, term) | + sub(term, term) | + mul(term, term) | + div(term, term) | + pow(term, term) +} +``` + +The `add` and `mul` operations are commutative, so as far as comparing them for semantic equality, `add(a, b)` is equal to `add(b, a)` etc. We may want this behavior when for example doing constant folding: + +```fn + ... + sub(a, a) { num(0) } + ... +``` + +Where the two arguments to `sub` should match if they are semantically equal, without needing to create cases for every possible arrangement of their components. + +It's trivial to write a function to express this for a top-level comparison: + +```fn +fn eq_term { + (num(a), num(a)) | + (var(a), var(a)) | + (add(a, b), add(a, b)) | + (add(b, a), add(a, b)) | + (sub(a, b), sub(a, b)) | + (mul(a, b), mul(a, b)) | + (mul(b, a), mul(a, b)) | + (div(a, b), div(a, b)) | + (pow(a, b), pow(a, b)) { true } + (_, _) { false } +} +``` + +but to be correct the function must also use its own definition: the unifying `a` and `b` variables need to be compared in the same way. + +What makes this useful is that since the function has to override the built-in comparison operations to work in the first place, it should naturally do so for all comparisons of that type. + +## How Recursion Works + +The bespoke comparator must be invoked automatically during pattern matching. To achieve this, when TPMC compiles a pattern like `(add(a, b), add(a, b))`, it generates normal `eq` operations for the pattern variables, but the type checker later recognizes that `a` and `b` have type `term` and substitutes those `eq` calls with calls to `eq$term`. + +Similarly, in the constant folding example: + +```fn + sub(a, a) { num(0) } +``` + +The pattern `sub(a, a)` requires the two arguments to match. TPMC generates an `eq` comparison; since both arguments are type `term`, the type checker substitutes `eq$term`, enabling semantic equality (so `sub(x+1, 1+x)` matches, as does `sub(y*2, 2*y)`). + +Assuming a similar definition strategy to `print`, like: `eq type { ...body... }` the type of the function would be constrained to `type -> type -> bool`. When an `eq` comparison is reached in the type checker while the type of the operands is known, the compile-time environment is checked for a bespoke comparator and a call to that is substituted in place of the `eq`. + +It would be simple enough to do a to-string and compare strings for structural equality if we needed it occasionally. + +## Implementation + +Looking at how the parser currently handles analogous `print` tokens in a `let`, it just calls the `defun` parser, passing it a flag `isPrinter = true` which causes the parser to generate a `print$type` name for the function being defined. + +We could extend this by replacing the boolean with an enum, values `FUNCTION`, `PRINTER`, `EQUALITY` for now. Then the `defun` would generate an `eq$type` name if given an `EQUALITY` type. We just need to decide what the initiating token is. + +On encountering an `eq$type` function, the typechecker would immediately create the type signature `type -> type -> bool` and unify the function against it before type checking the function body. Any type mismatches will produce normal type checking errors. On encountering an `eq` primitive operation, the type checker would inspect the current `TcEnv` for an `eq$type` function and if found would replace the `eq` with a call to that function. If the type encountered is namespace qualified then the type checker must inspect that namespace for the equivalent `eq$type` function and namespace-qualify the invocation. + +TPMC requires no changes—it continues to generate `eq` operations for pattern variable comparisons as it always has. The type checker then substitutes these with bespoke comparator calls when appropriate. + +### Limitation + +The surface level `==` is a user defined operator that expands to a call to a lazy function: `x == y` becomes `(opLazy$1 (λ () x) (λ () y))` where `opLazy$1` is bound to `(λ (x1 x2) (eq (x1) (x2)))`. There is no way currently to get from `x == y` to `(eq x y)` - though it would be great if we could, likewise for the other primitives. Also if we plan to do constant folding in a later compiler pass we'll need to fix this. That's for another day. + +## Results + +This is a TPMC graph of that eq$term function after implementation. + +```mermaid +--- +title: eq$term +--- +flowchart LR +T208("p$107
[]
(arcs 7)") +T209("p$108
[p$108 p$107$0]
(arcs 2)") +T210("p$108$0
[p$107$0 p$108$0]
(arcs 2)") +F197("(begin constructor:true)
[p$107$0]") +T210 --"p$108$0:p$107$0:_==p$108$0:var a
[p$107$0]"--> F197 +F206("(begin constructor:false)
[]") +T210 --"p$108$0:_
[]"--> F206 +T209 --"p$108:var(p$108$0:_)
[p$107$0]"--> T210 +T209 --"p$108:_
[]"--> F206 +T208 --"p$107:var(p$107$0:_)
[p$108]"--> T209 +T211("p$108
[p$108 p$107$0]
(arcs 2)") +T212("p$108$0
[p$107$0 p$108$0]
(arcs 2)") +F198("(begin constructor:true)
[p$107$0]") +T212 --"p$108$0:p$107$0:_==p$108$0:var a
[p$107$0]"--> F198 +T212 --"p$108$0:_
[]"--> F206 +T211 --"p$108:num(p$108$0:_)
[p$107$0]"--> T212 +T211 --"p$108:_
[]"--> F206 +T208 --"p$107:num(p$107$0:_)
[p$108]"--> T211 +T213("p$108
[p$108 p$107$0 p$107$1]
(arcs 2)") +T214("p$108$0
[p$107$0 p$108$0 p$107$1 p$108$1]
(arcs 2)") +T215("p$108$1
[p$107$0 p$107$1 p$108$1]
(arcs 2)") +F199("(begin constructor:true)
[p$107$0 p$107$1]") +T215 --"p$108$1:p$107$1:_==p$108$1:var b
[p$107$0 p$107$1]"--> F199 +T215 --"p$108$1:_
[]"--> F206 +T214 --"p$108$0:p$107$0:_==p$108$0:var a
[p$107$0 p$107$1 p$108$1]"--> T215 +T214 --"p$108$0:_
[]"--> F206 +T213 --"p$108:pow(p$108$0:_, p$108$1:_)
[p$107$0 p$107$1]"--> T214 +T213 --"p$108:_
[]"--> F206 +T208 --"p$107:pow(p$107$0:_, p$107$1:_)
[p$108]"--> T213 +T216("p$108
[p$108 p$107$0 p$107$1]
(arcs 2)") +T217("p$108$0
[p$107$0 p$108$0 p$107$1 p$108$1]
(arcs 2)") +T218("p$108$1
[p$107$0 p$107$1 p$108$1]
(arcs 2)") +F200("(begin constructor:true)
[p$107$0 p$107$1]") +T218 --"p$108$1:p$107$1:_==p$108$1:var b
[p$107$0 p$107$1]"--> F200 +T218 --"p$108$1:_
[]"--> F206 +T217 --"p$108$0:p$107$0:_==p$108$0:var a
[p$107$0 p$107$1 p$108$1]"--> T218 +T217 --"p$108$0:_
[]"--> F206 +T216 --"p$108:div(p$108$0:_, p$108$1:_)
[p$107$0 p$107$1]"--> T217 +T216 --"p$108:_
[]"--> F206 +T208 --"p$107:div(p$107$0:_, p$107$1:_)
[p$108]"--> T216 +T219("p$108
[p$108 p$107$0 p$107$1]
(arcs 2)") +T220("p$108$0
[p$107$0 p$108$0 p$107$1 p$108$1]
(arcs 3)") +T221("p$108$1
[p$107$0 p$107$1 p$108$1]
(arcs 2)") +F201("(begin constructor:true)
[p$107$0 p$107$1]") +T221 --"p$108$1:p$107$0:_==p$108$1:var b
[p$107$0 p$107$1]"--> F201 +T221 --"p$108$1:_
[]"--> F206 +T220 --"p$108$0:p$107$1:_==p$108$0:var a
[p$107$0 p$107$1 p$108$1]"--> T221 +T222("p$108$1
[p$107$0 p$107$1 p$108$1]
(arcs 2)") +F202("(begin constructor:true)
[p$107$0 p$107$1]") +T222 --"p$108$1:p$107$1:_==p$108$1:var b
[p$107$0 p$107$1]"--> F202 +T222 --"p$108$1:_
[]"--> F206 +T220 --"p$108$0:p$107$0:_==p$108$0:var a
[p$107$0 p$107$1 p$108$1]"--> T222 +T220 --"p$108$0:_
[]"--> F206 +T219 --"p$108:mul(p$108$0:_, p$108$1:_)
[p$107$0 p$107$1]"--> T220 +T219 --"p$108:_
[]"--> F206 +T208 --"p$107:mul(p$107$0:_, p$107$1:_)
[p$108]"--> T219 +T223("p$108
[p$108 p$107$0 p$107$1]
(arcs 2)") +T224("p$108$0
[p$107$0 p$108$0 p$107$1 p$108$1]
(arcs 2)") +T225("p$108$1
[p$107$0 p$107$1 p$108$1]
(arcs 2)") +F203("(begin constructor:true)
[p$107$0 p$107$1]") +T225 --"p$108$1:p$107$1:_==p$108$1:var b
[p$107$0 p$107$1]"--> F203 +T225 --"p$108$1:_
[]"--> F206 +T224 --"p$108$0:p$107$0:_==p$108$0:var a
[p$107$0 p$107$1 p$108$1]"--> T225 +T224 --"p$108$0:_
[]"--> F206 +T223 --"p$108:sub(p$108$0:_, p$108$1:_)
[p$107$0 p$107$1]"--> T224 +T223 --"p$108:_
[]"--> F206 +T208 --"p$107:sub(p$107$0:_, p$107$1:_)
[p$108]"--> T223 +T226("p$108
[p$108 p$107$0 p$107$1]
(arcs 2)") +T227("p$108$0
[p$107$0 p$108$0 p$107$1 p$108$1]
(arcs 3)") +T228("p$108$1
[p$107$0 p$107$1 p$108$1]
(arcs 2)") +F204("(begin constructor:true)
[p$107$0 p$107$1]") +T228 --"p$108$1:p$107$0:_==p$108$1:var b
[p$107$0 p$107$1]"--> F204 +T228 --"p$108$1:_
[]"--> F206 +T227 --"p$108$0:p$107$1:_==p$108$0:var a
[p$107$0 p$107$1 p$108$1]"--> T228 +T229("p$108$1
[p$107$0 p$107$1 p$108$1]
(arcs 2)") +F205("(begin constructor:true)
[p$107$0 p$107$1]") +T229 --"p$108$1:p$107$1:_==p$108$1:var b
[p$107$0 p$107$1]"--> F205 +T229 --"p$108$1:_
[]"--> F206 +T227 --"p$108$0:p$107$0:_==p$108$0:var a
[p$107$0 p$107$1 p$108$1]"--> T229 +T227 --"p$108$0:_
[]"--> F206 +T226 --"p$108:add(p$108$0:_, p$108$1:_)
[p$107$0 p$107$1]"--> T227 +T226 --"p$108:_
[]"--> F206 +T208 --"p$107:add(p$107$0:_, p$107$1:_)
[p$108]"--> T226 +``` + +And the resulting IR (after desugaring). You can see the inner recursive calls to `eq$term`. + +```scheme +(λ (p$107 p$108) + (letrec (($tpmc206 (λ () 0))) + (match (vec 0 p$107) + ((6) + ((λ (p$107$0) + (match (vec 0 p$108) + ((6) + ((λ (p$108$0) + (if (== p$107$0 p$108$0) 1 ($tpmc206))) + (vec 1 p$108))) + ((5 4 3 2 1 0) ($tpmc206)))) + (vec 1 p$107))) + ((5) + ((λ (p$107$0) + (match (vec 0 p$108) + ((5) + ((λ (p$108$0) + (if (== p$107$0 p$108$0) 1 ($tpmc206))) + (vec 1 p$108))) + ((6 4 3 2 1 0) ($tpmc206)))) + (vec 1 p$107))) + ((4) + ((λ (p$107$1) + ((λ (p$107$0) + (match (vec 0 p$108) + ((4) + ((λ (p$108$1) + ((λ (p$108$0) + (if (eq$term p$107$0 p$108$0) + (if (eq$term p$107$1 p$108$1) + 1 + ($tpmc206)) + ($tpmc206))) + (vec 1 p$108))) + (vec 2 p$108))) + ((6 5 3 2 1 0) ($tpmc206)))) + (vec 1 p$107))) + (vec 2 p$107))) + ((3) + ((λ (p$107$1) + ((λ (p$107$0) + (match (vec 0 p$108) + ((3) + ((λ (p$108$1) + ((λ (p$108$0) + (if (eq$term p$107$0 p$108$0) + (if (eq$term p$107$1 p$108$1) + 1 + ($tpmc206)) + ($tpmc206))) + (vec 1 p$108))) + (vec 2 p$108))) + ((6 5 4 2 1 0) ($tpmc206)))) + (vec 1 p$107))) + (vec 2 p$107))) + ((2) + ((λ (p$107$1) + ((λ (p$107$0) + (match (vec 0 p$108) + ((2) + ((λ (p$108$1) + ((λ (p$108$0) + (if (eq$term p$107$1 p$108$0) + (if (eq$term p$107$0 p$108$1) + 1 + ($tpmc206)) + (if (eq$term p$107$0 p$108$0) + (if (eq$term p$107$1 p$108$1) + 1 + ($tpmc206)) + ($tpmc206)))) + (vec 1 p$108))) + (vec 2 p$108))) + ((6 5 4 3 1 0) ($tpmc206)))) + (vec 1 p$107))) + (vec 2 p$107))) + ((1) + ((λ (p$107$1) + ((λ (p$107$0) + (match (vec 0 p$108) + ((1) + ((λ (p$108$1) + ((λ (p$108$0) + (if (eq$term p$107$0 p$108$0) + (if (eq$term p$107$1 p$108$1) + 1 + ($tpmc206)) + ($tpmc206))) + (vec 1 p$108))) + (vec 2 p$108))) + ((6 5 4 3 2 0) ($tpmc206)))) + (vec 1 p$107))) + (vec 2 p$107))) + ((0) + ((λ (p$107$1) + ((λ (p$107$0) + (match (vec 0 p$108) + ((0) + ((λ (p$108$1) + ((λ (p$108$0) + (if (eq$term p$107$1 p$108$0) + (if (eq$term p$107$0 p$108$1) + 1 + ($tpmc206)) + (if (eq$term p$107$0 p$108$0) + (if (eq$term p$107$1 p$108$1) + 1 + ($tpmc206)) + ($tpmc206)))) + (vec 1 p$108))) + (vec 2 p$108))) + ((6 5 4 3 2 1) ($tpmc206)))) + (vec 1 p$107))) + (vec 2 p$107)))))) +``` diff --git a/docs/bugs/import-data.drawio b/docs/bugs/import-data.drawio new file mode 100644 index 00000000..5a4d34dc --- /dev/null +++ b/docs/bugs/import-data.drawio @@ -0,0 +1,153 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/bugs/import-data.md b/docs/bugs/import-data.md new file mode 100644 index 00000000..0339d8f9 --- /dev/null +++ b/docs/bugs/import-data.md @@ -0,0 +1,136 @@ +# Cannot import non-lambdas from a namespace + +This bug was fixed. + +The test file `tests/fn/test_import_data.fn` and the supporting `tests/fn/import_data.fn` demonstrate +the problem. + +If `import_data.fn` is written as + +```fn +namespace + fn data() { 1 } +``` + +and `test_import_data.fn` as + +```fn +let + link "import_data.fn" as Data; +in + Data.data() +``` + +Then the file compiles and runs with no problems. + +If instead `import_data.fn` is written as: + +```fn +namespace + data = 1 +``` + +and `test_import_data.fn` as + +```fn +let + link "import_data.fn" as Data; +in + Data.data +``` + +Then there is an error: + +```text +no binding for var 'data$0' in annotateAexpVar [tests/fn/test_import_data.fn +4] at +109 src/annotate.c +``` + +(`data$0` is due to a prior alpha-conversion step, the original variable is just `data`) + +The primary difference is in how namespaces treat functions as opposed to data. Functions are hoisted into a `letrec`, while plain data is pushed down into a `let*`, then a later simplification step rewrites `let*` to a nest of `let` then further rewrites `let` to an anonymous lambda application. + +If I run the test with `--dump-alpha` to dump the IR after alpha conversion, the relevant section for the plain `data = 1` version looks like this: + +```scheme +(begin (nameSpaces [((λ (data$0) env) 1)]) (lookUp 0 data$0)) +``` + +While the version with `fn data() { 1 }` looks like this: + +```scheme +(begin (nameSpaces [(letrec ((data$0 (λ () 1))) env)]) ((lookUp 0 data$0))) +``` + +I should also explain what that `env` is. It's a special token representing the "body" of the namespace, injected by the parser, which tells downstream processing steps that they have reached the heart of the namespace and the result is effectively the environment current at that point. + +I need to stress that **this used to work** and recent changes have broken it. +`annotate.c` is the step that gives each variable a "De Bruijn index". + +## Investigation Findings + +### The commit that likely introduced this bug + +Commit `dd3dd1a` ("separate let-star construct") changed `lambda_conversion.c` to use +`makeLamExp_LetStar` instead of `makeLamExp_Let` for non-lambda bindings in namespaces: + +```diff +- letRecBody = makeLamExp_Let(CPI(varDefsList), varDefsList, letRecBody); ++ letRecBody = makeLamExp_LetStar(CPI(varDefsList), varDefsList, letRecBody); +``` + +### Root cause analysis + +The problem occurs in `annotate.c` in the function `annotateAexpNameSpaceArray`. + +**Working case (`letrec`)**: When the namespace body is `(letrec ((data$0 (λ () 1))) env)`: + +1. `annotateAexpNameSpaceArray` creates `env2` with `isNameSpace = true` +2. `annotateCexpLetRec` creates a child environment, adds `data$0` to it +3. The `env` token is reached, `annotateExpEnv` returns the environment chain including `data$0` +4. This environment (with `data$0`) is pushed to `nsEnvs` +5. Later lookup succeeds because `data$0` is in the recorded namespace environment + +**Broken case (lambda application)**: When the namespace body is `((λ (data$0) env) 1)`: + +1. `annotateAexpNameSpaceArray` creates `env2` with `isNameSpace = true` +2. The body is a `CexpApply`, so `annotateCexpApply` is called +3. `annotateAexp(x->function, env)` annotates the lambda: + - `annotateAexpLam` creates a child environment, adds `data$0` to it + - The `env` token inside the lambda triggers `annotateExpEnv`, which returns this environment + - **But this return value is discarded** - `annotateCexpApply` ignores it +4. `annotateCexpApply` returns `env2` (the original, with **no bindings**) +5. `env2` (empty) is pushed to `nsEnvs` +6. Later, `lookUp 0 data$0` fails because `data$0` is not in `nsEnvs[0]` + +### The specific code issue + +In [annotate.c](../../src/annotate.c#L141-L152): + +```c +static AnfEnv *annotateCexpApply(CexpApply *x, AnfEnv *env) { + annotateAexp(x->function, env); // Return value ignored! + annotateAexpList(x->args, env); + return env; // Returns original env, not the one from the lambda +} +``` + +The return value from `annotateAexp(x->function, ...)` is ignored. When the function is a +lambda containing the `env` token, the environment captured inside that lambda (which includes +the lambda's parameters) is lost. + +### Why this worked before + +Before the `let*` separation, non-lambda bindings in namespaces were likely processed +differently - possibly they stayed in the `letrec` or were handled in a way that didn't +rely on lambda application semantics for environment capture. + +### Potential fixes (not implemented) + +1. **Special-case lambda applications in namespaces**: Detect when a `CexpApply` has a lambda + as its function and the lambda body contains the `env` token, then capture that environment. + +2. **Don't desugar `let*` to lambda applications for namespaces**: Keep a `Let` construct in + ANF that preserves the binding semantics. + +3. **Change how namespace environments are captured**: Instead of relying on the return value + from `annotateExp`, explicitly traverse the namespace body to find all bindings. diff --git a/docs/bugs/namespace-let-bytecode.md b/docs/bugs/namespace-let-bytecode.md new file mode 100644 index 00000000..ccaf6510 --- /dev/null +++ b/docs/bugs/namespace-let-bytecode.md @@ -0,0 +1,458 @@ +# Namespace Let-to-Lambda Bytecode Control Flow Issue + +This document captures the investigation into why desugared `let`/`let*` +in namespaces causes early program exit after fixing the annotation +issue in `import-data.md`. + +## Problem Statement + +After fixing the `isCapturing` flag issue in `annotate.c`, the test +`test_import_data.fn` no longer crashes during annotation, but the program +exits before printing the imported value. The bytecode execution appears +to return from the program prematurely. + +## Bytecode Generation Comparison + +### `AnfExpLet` (the unused but correct approach) + +From [bytecode.c#L639-L649](../../src/bytecode.c#L639-L649): + +```c +void writeAnfExpLet(AnfExpLet *x, ByteCodeArray *b, LocationArray *L) { + writeLocation(CPI(x), b, L); + addByte(b, BYTECODES_TYPE_LET); // Push continuation for body + Control patch = reserveWord(b); + writeAnfExp(x->val, b, L); // Compile the value expression + writeLocation(CPI(x->val), b, L); + addByte(b, BYTECODES_TYPE_RETURN); // Return from value, resume at body + writeCurrentAddressAt(patch, b); + writeAnfExp(x->body, b, L); // Compile the body +} +``` + +Generated bytecode sequence: + +``` +LET [body_addr] ; Create continuation pointing to body + ; Execute value expression +RETURN ; Pop continuation, jump to body with val on stack + ; Execute body with val available +``` + +### `AexpLam` (lambda in function position) + +From [bytecode.c#L182-L193](../../src/bytecode.c#L182-L193): + +```c +void writeAexpLam(AexpLam *x, ByteCodeArray *b , LocationArray *L) { + addByte(b, BYTECODES_TYPE_LAM); + addByte(b, x->nArgs); + addByte(b, x->letRecOffset); + Control patch = reserveWord(b); + writeAnfExp(x->exp, b, L); // Compile lambda body + addByte(b, BYTECODES_TYPE_RETURN); // Return from lambda + writeCurrentAddressAt(patch, b); +} +``` + +### `CexpApply` (function application) + +From [bytecode.c#L319-L374](../../src/bytecode.c#L319-L374): + +```c +void writeCexpApply(CexpApply *x, ByteCodeArray *b, LocationArray *L) { + // ... handling for over-application ... + writeAexpList(x->args, b, L); // Push arguments + writeAexp(x->function, b, L); // Push function (closure) + writeLocation(CPI(x), b, L); + addByte(b, BYTECODES_TYPE_APPLY); // Apply function + addByte(b, n); +} +``` + +## The Critical Difference + +### `LET` instruction (VM side) + +From [step.c#L1054-L1062](../../src/step.c#L1054-L1062): + +```c +case BYTECODES_TYPE_LET: { + int offset = readCurrentOffset(); + letStackFrame(state.S); + state.K = makeKont(offset, state.E, false, state.K); // Push continuation + validateLastAlloc(); +} break; +``` + +The `LET` instruction: + +1. Creates a continuation pointing to the **body** code +2. Pushes it onto the continuation stack (`state.K`) +3. Execution continues to the value expression +4. When the value expression's `RETURN` fires, it pops this continuation and jumps to body + +### `APPLY` instruction (VM side) + +From [step.c#L852-L858](../../src/step.c#L852-L858): + +```c +case BYTECODES_TYPE_APPLY: { + int nArgs = readCurrentByte(); + applyProc(nArgs); +} break; +``` + +The `APPLY` instruction: + +1. Pops the closure from the stack +2. Calls `exactCallFromClo()` which sets `state.C = clo->C` (jumps into lambda body) +3. Does **NOT** create a continuation for what comes after the `APPLY` +4. When the lambda body's `RETURN` fires, it pops the **outer** continuation + +### `RETURN` instruction (VM side) + +From [step.c#L1151-L1165](../../src/step.c#L1151-L1165): + +```c +case BYTECODES_TYPE_RETURN: { + Value kont = value_Kont(state.K); + push(kont); + applyProc(1); // Apply current continuation to result + // ... +} break; +``` + +## Root Cause + +When `let x = val in body` is desugared to `((λ (x) body) val)`: + +**With `LET` instruction:** + +``` +LET [body_addr] ; state.K = kont(body, ..., state.K) + +RETURN ; pop kont, jump to body + +``` + +The body is reached because `LET` created a continuation for it. + +**With lambda application (current behavior):** + +``` + ; push 1 +LAM ... ; create closure for (λ (x) body) + + RETURN ; **returns to outer continuation** +APPLY 1 ; call closure, state.C = closure.C (into lambda) + ; NO continuation created for after APPLY! +``` + +The `APPLY` instruction jumps into the lambda body. When the lambda's +`RETURN` executes, it pops `state.K` which is the **caller's** +continuation (possibly the program's top-level continuation), not a +continuation for code after the `APPLY`. + +This is correct behavior for normal function calls - you want to return +to the caller. But for simulating `let`, there's no code "after" the +`APPLY` because the body is **inside** the lambda. + +## Why This Is a Problem for Namespaces + +In the namespace case: + +``` +(begin (nameSpaces [((λ (data$0) env) 1)]) (lookUp 0 data$0)) +``` + +The execution flow: + +1. Push 1 +2. Create closure for `(λ (data$0) env)` +3. `APPLY 1` - jump into lambda +4. Lambda body executes `env` token handling +5. `RETURN` - pops outer continuation, exits namespace setup entirely +6. `(lookUp 0 data$0)` is never reached because control never returns to it + +The `lookUp` code comes **after** the namespace setup, but the `RETURN` inside the +lambda skips over it. + +## Why This Works in Regular Function Bodies + +This issue is specific to namespaces and doesn't affect regular function bodies for two reasons: + +### Reason 1: Tail Position Behavior + +In regular function bodies, if a let-as-lambda is the **entire body** +of a function, the lambda's RETURN correctly returns to the function's +caller. This is the expected behavior - there's no code "after" the let +that needs to execute. + +### Reason 2: ANF Ensures Proper Continuations + +If code needs to execute **after** a let-as-lambda in a regular function, +ANF ensures the let-as-lambda is wrapped in an `AnfExpLet` which creates +the proper continuation. ANF normalization let-binds all non-atomic +expressions. + +### Reason 3: Namespace Bodies Expect "Fall-Through" Semantics + +The critical difference with namespaces is in how `writeCexpLetRec` vs `writeCexpApply` work: + +**`letrec` (working case)** generates: + +``` + +LETREC [n] ; patches closures, DOES NOT change state.C + ; falls through naturally +NS_END ; reached because execution continued sequentially +``` + +The `LETREC` instruction +([step.c#L1006-L1020](../../src/step.c#L1006-L1020)) just patches +closures and lets execution **continue to the next instruction**. It +doesn't jump anywhere. + +**Lambda application (broken case)** generates: + +``` + + +APPLY n ; JUMPS into lambda (state.C = closure.C) +NS_END ; NEVER REACHED - APPLY jumped away +``` + +When `APPLY` executes, it jumps into the lambda. When the lambda's `RETURN` executes, +it pops `state.K` which points to the outer caller, completely bypassing `NS_END`, +`NS_FINISH`, and `lookUp`. + +### Summary + +Namespace bodies are designed for code that "falls through" sequentially to `NS_END` +and beyond. `letrec` supports this because it doesn't change control flow. But lambda +applications use call/return semantics that jump away and never return to the +subsequent instructions. + +## Nested Let Analysis + +When there are multiple non-lambda bindings in a namespace (e.g., `data = 1; b = 2`), +they become nested lambda applications: + +```scheme +((λ (data$0) ((λ (b$0) env) 2)) 1) +``` + +**Bytecode generated:** + +``` +NS_START [1] +; outer apply: ((λ (data$0) ...) 1) +STDINT 1 ; push 1 +LAM 1 ... ; create outer closure + ; inner apply: ((λ (b$0) env) 2) + STDINT 2 ; push 2 + LAM 1 ... ; create inner closure + ; env token - does nothing in bytecode + RETURN ; *** jumps to outer continuation *** + APPLY 1 ; never reached + RETURN ; never reached +APPLY 1 ; enter outer lambda +NS_END [...] ; never reached +NS_FINISH [...] ; never reached + ; never reached +``` + +**Execution trace:** + +1. `NS_START` - allocate space +2. Push 1 +3. Create outer closure, jump to end of outer lambda +4. `APPLY 1` - `state.C = outer_lambda_body`, **no continuation pushed** +5. (inside outer lambda) Push 2 +6. Create inner closure, jump to end of inner lambda +7. `APPLY 1` - `state.C = inner_lambda_body`, **still no continuation pushed** +8. (inside inner lambda) `env` token - no-op +9. `RETURN` - pops `state.K` which is the **original outer continuation** (before namespace started) + +The nested case has the same problem - all the `APPLY` instructions jump without +creating continuations, so the innermost `RETURN` jumps all the way back to before +the namespace started. + +**Any fix needs to handle arbitrarily deep nesting.** The number of nested lambda +applications equals the number of non-lambda bindings in the namespace. + +## Potential Fixes + +### Option 1: Keep `AnfExpLet` in ANF for namespace contexts + +Don't desugar `let`/`let*` to lambda applications when inside a namespace body. +Keep the `AnfExpLet` structure so `writeAnfExpLet` generates the correct `LET` +instruction with proper continuation. + +**Downside:** Requires tracking "namespace context" through multiple transformation +passes (desugar, ANF normalize) to preserve `Let` only in namespace bodies. + +### Option 2: Recognize let-shaped applications in bytecode generation + +In `writeCexpApply`, detect when the function is an immediate lambda (not a variable) +and emit `LET`-style bytecode instead: + +```c +if (x->function->type == AEXP_TYPE_LAM && x->nArgs == 1) { + // Emit LET-style code instead of APPLY + addByte(b, BYTECODES_TYPE_LET); + Control patch = reserveWord(b); + writeAexpList(x->args, b, L); // value + addByte(b, BYTECODES_TYPE_RETURN); + writeCurrentAddressAt(patch, b); + writeAnfExp(x->function->val.lam->exp, b, L); // body +} +``` + +**Advantage:** Naturally handles arbitrary nesting - each recognized lambda-application +emits `LET` + `RETURN` which creates the right continuation chain. No need to track +"namespace context" through earlier passes. + +**Note:** This would apply globally, not just to namespaces. This is arguably correct +since `((λ (x) body) val)` is semantically equivalent to `let x = val in body`. + +### Option 3: Add a new bytecode for "apply-and-continue" + +Create a variant of `APPLY` that also creates a continuation for code after it, +similar to how `CALLCC` works but for regular calls. + +**Downside:** Requires changes to both bytecode generation and the VM. + +### Option 4: Use the `env` token to escape nested returns + +The `env` token currently generates no bytecode: + +```c +case ANFEXP_TYPE_ENV: + break; +``` + +One could imagine making `env` emit a special bytecode that: + +1. "Commits" the current stack frame as the namespace environment +2. Performs a non-local jump past all pending `RETURN`s directly to `NS_END` + +This would work because `env` marks the exact point where the namespace environment +should be captured - the "heart" of the namespace body. + +**Challenges:** + +1. The `RETURN` after the lambda body is emitted unconditionally by `writeAexpLam` - + you'd need to somehow suppress or redirect it +2. Would require VM changes to handle a new "escape" or "fall-through" semantic +3. More complex than Option 2 since it requires coordinating between multiple + bytecode emission points + +**Potential approach:** Have `env` emit an `ENV_ESCAPE` bytecode that sets a flag. +Then modify the VM's `RETURN` handling to check this flag and skip the return, +instead continuing to the next instruction. But this adds complexity to the +common-path `RETURN` handling. + +This approach is more invasive than Option 2 and doesn't provide +clear benefits. However, it might be useful if there are other reasons to give +`env` runtime behavior in the future. + +## TCO Analysis for Option 2 + +A concern with Option 2 is whether it preserves tail call optimization. + +**With APPLY (current behavior):** + +``` +STDINT 1 +LAM 1 ... + + RETURN ; returns to K +APPLY 1 ; jumps into lambda, K unchanged +``` + +If `` ends with a tail call, that call uses the unchanged K - proper TCO. + +**With LET (proposed Option 2):** + +``` +LET [body] ; K = kont(body, E, K₀) +STDINT 1 +RETURN ; pop kont, K = K₀, jump to body + ; K is back to K₀ +``` + +If `` ends with a tail call, that call uses K₀ - the same K as before the LET. + +**TCO is preserved** because: + +1. The `LET` pushes a continuation pointing to the body +2. The `RETURN` pops that continuation and restores K to its original state (K₀) +3. Any tail call in the body then uses this restored K₀ + +The key insight is that after `RETURN` jumps to the body, the continuation stack +is back to what it was *before* the `LET`. So from the body's perspective, the K +stack is the same as it would have been with a direct `APPLY`. + +**One subtle difference:** With `APPLY`, the lambda body is wrapped in `LAM...RETURN`. +If the body ends with a non-tail-call expression (just a value), the `RETURN` returns +it to K. With the `LET` approach, the body is written inline without a trailing +`RETURN` - it relies on the outer context to handle the result. + +In the namespace case this is fine because `NS_END` follows the body. For other +contexts where immediate lambda applications appear, we should verify the outer +context properly handles the result (either more code follows, or an outer `RETURN` +exists). + +## Recommendation + +~~Option 2 is attractive because:~~ + +1. ~~It's a localized fix in `writeCexpApply` - no changes to earlier passes~~ +2. ~~It naturally handles arbitrary nesting depth~~ +3. ~~It's semantically correct - immediate lambda applications ARE let bindings~~ +4. ~~It doesn't require re-introducing `Let` as a separate ANF construct~~ +5. ~~TCO is preserved - the continuation stack is restored before the body executes~~ + +### Option 2 Implementation Attempt (Failed) + +Option 2 was attempted but failed. The bytecode-only fix breaks the correspondence +between what annotation calculates and what bytecode produces: + +- **Annotation phase** calculates `nBindings` by counting bindings in the environment + chain, which includes the lambda's parameter (e.g., `data$0`) +- **Bytecode phase** (with the fix) skips the lambda entirely, just pushing the value + +The `NS_END` instruction uses `nBindings` to calculate where to poke the namespace +value on the stack, and `NS_PUSHSTACK` uses offsets calculated during annotation. +These no longer match the actual stack layout when bytecode skips the lambda. + +Fixing this would require coordinating changes across both annotation and bytecode +generation, significantly increasing complexity. + +### Option 5: Disallow non-lambda bindings in namespaces + +The simplest solution is to disallow plain data bindings in namespaces entirely. +Namespaces would only allow: + +- Function definitions (`fn name(...) { ... }`) +- Type definitions (`typedef ...`) +- Operator definitions (`operator ...`) +- Links to other namespaces (`link "..." as ...`) + +**Rationale:** + +1. Namespaces are primarily for organizing code - functions, types, operators +2. Data can still be exposed via nullary functions: `fn data() { 1 }` instead of `data = 1` +3. It's a clean semantic restriction at the source level rather than a compiler hack +4. Keeps the implementation simpler and behavior predictable +5. The `letrec` structure is preserved, which works correctly with namespace bytecode + +**Implementation:** Check in `lambda_conversion.c` during `lamConvert` - if processing +a namespace and `varDefsList` is non-NULL after `separateLambdas`, emit an error. + +## Current Status + +Option 5 is the recommended approach. The restriction is reasonable and avoids +the complexity of coordinating changes across multiple compiler phases. diff --git a/docs/bugs/tpmc-comparison-column-ordering.md b/docs/bugs/tpmc-comparison-column-ordering.md new file mode 100644 index 00000000..d6a27e2f --- /dev/null +++ b/docs/bugs/tpmc-comparison-column-ordering.md @@ -0,0 +1,840 @@ +# TPMC Comparison Column Ordering Bug + +## Summary + +The pseudo-unification feature (where the same variable appearing twice in a pattern triggers an equality comparison) fails when the "previous" variable is nested deeper than the "current" variable in the pattern structure. + +## Reproducing Test Case + +File: `tests/fn/bug_unification.fn` + +```fn +let + typedef term { + num(number) | + mul(term, term) + } + + fn broken { + (mul(mul(num(1), x), x)) { num(1) } + (mul(x, mul(num(1), x))) { num(1) } // This pattern causes the bug + (x) { x } + } +in + broken(mul(num(2), mul(num(1), num(2)))) +``` + +Error: + +``` +undefined variable p$106$1$1 in tests/fn/bug_unification.fn, line 8 +``` + +## Analysis + +### Pattern Structure + +For the problematic pattern `(mul(x, mul(num(1), x)))`: + +- `p$106` = root argument +- `p$106$0` = first child of outer mul = `x` (first occurrence) +- `p$106$1` = second child of outer mul = `mul(num(1), x)` +- `p$106$1$0` = first child of inner mul = `num(1)` +- `p$106$1$1` = second child of inner mul = `x` (second occurrence → becomes comparison) + +When the second `x` is encountered during `replaceComparisonRule()` in `tpmc_logic.c`, it's converted to a `TpmcComparisonPattern` with: + +- `previous` = the pattern for the first `x` (path: `p$106$0`) +- `current` = the pattern for the second `x` (path: `p$106$1$1`) + +### The Problem + +The comparison requires both variables to be bound before the equality test. Variable binding occurs when the TPMC descends into a constructor pattern and extracts its components. + +For this comparison to work: + +1. `p$106$0` must be bound first (when matching outer `mul(p$106$0:_, p$106$1:_)`) +2. `p$106$1$1` must be bound second (when matching inner `mul(p$106$1$0:_, p$106$1$1:_)`) +3. Only then can the comparison `p$106$0 == p$106$1$1` be evaluated + +However, the TPMC generates code that references `p$106$1$1` as a free variable at the top-level state, before descending into `p$106$1` to bind it. + +### Current Heuristic + +In `tpmc_match.c`, the `mixture()` function has this heuristic (lines 725-729): + +```c +int firstConstructorColumn = findFirstConstructorColumn(M); +// this heuristic allows for comparisons to work: +if (firstConstructorColumn > 0 && + columnHasComparisons(firstConstructorColumn, M)) { + firstConstructorColumn = 0; +} +``` + +This says: "if the selected column has comparisons, fall back to column 0 instead." + +This heuristic was added to fix an earlier bug (documented in `docs/lambda-conversion.md`) where the comparison variable was in a different column. By forcing column 0 to be processed first, the variable would be bound. + +### Why the Heuristic Fails Here + +1. **Single-column case**: When there's only one column (or when column 0 is already selected), the heuristic doesn't help. The comparison is in column 0, but its `previous` variable is in a *sub-pattern* of the same column. + +2. **Nested structure**: The `previous` variable `p$106$0` and the comparison at `p$106$1$1` are both descendants of `p$106`. The issue isn't about which column to process first, but about the order of processing within the recursive descent into a single column's pattern. + +## TPMC Diagram Analysis + +The full TPMC graph: + +```mermaid +--- +title: broken +--- +flowchart TD +T196("p$106
[]
(arcs 2)") +T197("p$106$0
[p$106$1 p$106$1$1 p$106 p$106$0]
(arcs 2)") +T198("p$106$1
[p$106$0$0 p$106$1$1 p$106 p$106$0$1 p$106$0 p$106$1]
(arcs 3)") +T199("p$106$0$0
[p$106$1 p$106$0$0 p$106$1$1]
(arcs 2)") +T200("p$106$0$0$0
[p$106$1 p$106$1$1 p$106$0$0$0]
(arcs 2)") +F192("(begin (constructor:num 1))
[p$106$1]") +T200 --"p$106$0$0$0:1
[p$106$1]"--> F192 +F193("(begin (constructor:num 1))
[p$106$1$1]") +T200 --"p$106$0$0$0:_
[p$106$1$1]"--> F193 +T199 --"p$106$0$0:num(p$106$0$0$0:_)
[p$106$1 p$106$1$1]"--> T200 +T199 --"p$106$0$0:_
[p$106$1$1]"--> F193 +T198 --"p$106$1:p$106$0$1:_==p$106$1:_
[p$106$0$0 p$106$1$1 p$106$0$1]"--> T199 +T201("p$106$1$0
[p$106$0$0 p$106$1$1 p$106 p$106$1$0 p$106$0$1 p$106$0]
(arcs 2)") +T202("p$106$0$0
[p$106$1$0$0 p$106$0$0 p$106$1$1 p$106 p$106$0$1 p$106$0]
(arcs 1)") +T203("p$106$0$1
[p$106$1$0$0 p$106$1$1 p$106 p$106$0$1 p$106$0]
(arcs 1)") +T204("p$106$1$1
[p$106$1$0$0 p$106$1$1 p$106 p$106$0]
(arcs 2)") +T205("p$106$1$0$0
[p$106$1$0$0 p$106$1$1 p$106]
(arcs 2)") +T205 --"p$106$1$0$0:1
[p$106$1$1]"--> F193 +F194("(begin p$106)
[p$106]") +T205 --"p$106$1$0$0:_
[p$106]"--> F194 +T204 --"p$106$1$1:p$106$0:_==p$106$1$1:_
[p$106$1$0$0 p$106 p$106$0]"--> T205 +T204 --"p$106$1$1:_
[p$106]"--> F194 +T203 --"p$106$0$1:_
[p$106$1$0$0 p$106$1$1 p$106 p$106$0]"--> T204 +T202 --"p$106$0$0:_
[p$106$1$0$0 p$106$1$1 p$106 p$106$0$1 p$106$0]"--> T203 +T201 --"p$106$1$0:num(p$106$1$0$0:_)
[p$106$0$0 p$106$1$1 p$106 p$106$0$1 p$106$0]"--> T202 +T201 --"p$106$1$0:_
[p$106]"--> F194 +T198 --"p$106$1:mul(p$106$1$0:_, p$106$1$1:_)
[p$106$0$0 p$106 p$106$0$1 p$106$0]"--> T201 +T198 --"p$106$1:_
[p$106]"--> F194 +T197 --"p$106$0:mul(p$106$0$0:_, p$106$0$1:_)
[p$106$1 p$106$1$1 p$106]"--> T198 +T206("p$106$1
[p$106$1 p$106 p$106$0]
(arcs 2)") +T207("p$106$1$0
[p$106$1$1 p$106 p$106$1$0 p$106$0]
(arcs 2)") +T205 --"p$106$1$0$0:1
[p$106$1$1]"--> F193 +T205 --"p$106$1$0$0:_
[p$106]"--> F194 +T204 --"p$106$1$1:p$106$0:_==p$106$1$1:_
[p$106$1$0$0 p$106 p$106$0]"--> T205 +T204 --"p$106$1$1:_
[p$106]"--> F194 +T207 --"p$106$1$0:num(p$106$1$0$0:_)
[p$106$1$1 p$106 p$106$0]"--> T204 +T207 --"p$106$1$0:_
[p$106]"--> F194 +T206 --"p$106$1:mul(p$106$1$0:_, p$106$1$1:_)
[p$106 p$106$0]"--> T207 +T206 --"p$106$1:_
[p$106]"--> F194 +T197 --"p$106$0:_
[p$106$1 p$106]"--> T206 +T196 --"p$106:mul(p$106$0:_, p$106$1:_)
[p$106$1$1]"--> T197 +T196 --"p$106:_
[]"--> F194 +``` + +Key arc from the generated diagram: + +```mermaid +flowchart LR +T196("p$106
[]
(arcs 2)") +T197("p$106$0
[p$106$1 p$106$1$1 p$106 p$106$0]
(arcs 2)") +T196 --"p$106:mul(p$106$0:_, p$106$1:_)
[p$106$1$1]"--> T197 +``` + +The free variables list `[p$106$1$1]` indicates that the comparison variable is expected to already be available when transitioning from T196 (p$106). But at this point, we've only matched the outer `mul` - we haven't descended into `p$106$1` yet to bind `p$106$1$1`. + +## Proposed Solution Approaches + +### Approach 1: Track Comparison Dependencies + +Modify the algorithm to track which paths a comparison depends on. Before processing a comparison, ensure all paths it references have been bound. + +Implementation sketch: + +1. In `replaceComparisonRule()`, record that the comparison at path P depends on path Q (where Q is the `previous` pattern's path) +2. In `mixture()`, when a comparison is encountered, check if its dependency path is a descendant of the current test path +3. If so, defer the comparison until after descending far enough to bind the dependency + +### Approach 2: Path Prefix Analysis + +For a comparison at path `p$A$B$C` referencing a variable at path `p$X$Y`: + +- Find the longest common prefix of the two paths +- Ensure processing descends to at least that depth before the comparison is evaluated + +For the bug case: + +- Comparison is at `p$106$1$1` +- Reference is to `p$106$0` +- Common prefix is `p$106` +- The comparison should not be evaluated until after matching at `p$106$1` (to bind `p$106$1$1`) + +#### Implementation Mechanisms for Approach 2 + +The challenge is that the matrix-based algorithm doesn't directly track path depths - it works on columns, and the relationship between columns and paths changes as the algorithm recurses and expands sub-patterns. + +##### Mechanism A: Column Selection with Dependency Tracking + +In `mixture()`, before selecting a column to process: + +1. Scan all comparisons in the matrix +2. For each comparison, extract its `previous->path` (the referenced variable) +3. Check if that path is already "bound" (i.e., corresponds to a column that's already been processed in an ancestor call) +4. If a comparison references an unbound path, determine which column's expansion would eventually bind it +5. Prioritize processing that column first + +Difficulty: after sub-pattern expansion in `makeSubPatternMatrix()`, the column structure changes. A path like `p$106$1$1` doesn't exist as a column until we've descended through `p$106` and then `p$106$1`. + +##### Mechanism B: Propagate Comparisons Downward + +Instead of keeping a comparison at the level where it's discovered, propagate it down to the level where its referenced variable becomes bound: + +1. When a comparison at path `P` references path `Q`, compute the common prefix +2. "Attach" the comparison to the deepest state where both `P` and `Q` will be bound +3. During `mixture()`, comparisons only participate when they reach the appropriate depth + +Implementation: the `TpmcComparisonPattern` could carry a "minimum depth" or "required bindings" field that's checked before including it in column selection. + +This has been selected as the [Recommended Implementation](#recommended-implementation-approach-2-mechanism-b). + +##### Mechanism C: Two-Phase Processing Within `mixture()` + +1. First pass: identify all comparisons and their dependencies +2. Build a dependency graph: comparison C depends on paths P and Q +3. Process columns in topological order based on which paths they bind +4. Only "activate" a comparison when all its dependencies are satisfied + +##### Practical Combination + +The cleanest mechanism might combine approaches: during `replaceComparisonRule()` in `tpmc_logic.c`, annotate each comparison with the paths it requires. Then in `mixture()`, filter out comparisons whose requirements aren't yet met, effectively deferring them to a later recursive call where they'll reappear in the sub-matrix. + +### Approach 3: Reorder Bindings in Code Generation + +During the translation phase (`tpmc_translate.c`), ensure that within each arc's generated code, `let` bindings for constructor components are emitted before any comparison tests that reference those components. + +This doesn't change the DFA structure or backtracking behavior - comparisons still generate `if` expressions with proper alternative branches. It only changes the order of operations within each arc's code to ensure variables are bound before use. + +#### Translation Flow in `tpmc_translate.c` + +```text +tpmcTranslate() + └─> translateState() + └─> translateStateToInlineCode() + └─> translateTestState() + └─> translateArcList() + ├─> COMPARISON: translateComparisonArcListToIf() + │ └─> translateComparisonArcAndAlternativeToIf() + │ ├─> translateComparisonArcToTest() [generates: (eq a b)] + │ └─> translateArcToCode() + │ └─> prependLetBindings() [wraps body with let bindings] + │ + ├─> CONSTRUCTOR: translateConstructorArcList() + │ └─> translateArcToCode() + │ └─> prependLetBindings() + │ + └─> WILDCARD/CONSTANT: translateState() [recurse to next state] +``` + +#### Core Problem Location + +**Key function: `translateComparisonArcAndAlternativeToIf()`** (lines 245-259) + +```c +static LamExp * +translateComparisonArcAndAlternativeToIf(TpmcArc *arc, LamExpTable *lambdaCache, + LamExp *alternative) { + LamExp *test = translateComparisonArcToTest(arc); // generates (eq a b) + LamExp *consequent = translateArcToCode(arc, lambdaCache); + LamExp *res = makeLamExp_Iff(I, test, consequent, alternative); + // Result: (if (eq a b) consequent alternative) +} +``` + +The problem is the order of operations: + +1. `translateComparisonArcToTest()` generates `(eq p$previous p$current)` which references both paths +2. `translateArcToCode()` generates the consequent, which may call `prependLetBindings()` to bind variables +3. But the `let` bindings end up **inside** the consequent, **after** the comparison test + +#### Why `prependLetBindings()` Doesn't Help + +`prependLetBindings()` is called by `translateArcToCode()`, but only for constructor and tuple patterns: + +```c +static LamExp *translateArcToCode(TpmcArc *arc, LamExpTable *lambdaCache) { + LamExp *res = translateState(arc->state, lambdaCache); + switch (arc->test->pattern->type) { + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + case TPMCPATTERNVALUE_TYPE_TUPLE: + res = prependLetBindings(arc->test, arc->state->freeVariables, res); + break; + default: + break; // Comparisons fall through - no bindings added + } + return res; +} +``` + +When the arc's test is a comparison, no `let` bindings are prepended. The comparison's variables are assumed to already be bound. + +#### The Binding Chain Problem + +For `p$106$1$1` to be bound, we need: + +```scheme +(let ((p$106$1 (deconstruct p$106 1))) + (let ((p$106$1$1 (deconstruct p$106$1 1))) + (if (eq p$106$0 p$106$1$1) ...))) +``` + +But the comparison is being emitted at a state where we've only matched the outer `mul` structure. The nested path `p$106$1$1` requires descending into `p$106$1` first. + +#### Areas That Would Need to Change + +1. **`translateComparisonArcAndAlternativeToIf()`** - Primary target. Currently generates the comparison test before any bindings for the referenced paths. + +2. **Need ancestor context** - The binding for `p$106$1$1` comes from deconstructing `p$106$1`. But at the point where the comparison is translated, we don't have access to the ancestor arc that provides that binding. + +3. **`translateTestState()`** - Potential refactoring point. Could scan arcs for comparisons, identify required bindings, and emit them before calling `translateArcList()`. + +4. **`translateArcList()`** - May need comparison-aware preprocessing to separate "binding emission" from "test emission". + +#### Suggested Refactoring Strategy + +1. **Add a "required bindings" analysis pass** before translation + - For each comparison, determine what paths need to be bound + - Build a map from test states to required bindings + +2. **Modify `translateTestState()`** to emit bindings first + - Before translating arcs, emit `let` bindings for comparison-required paths + - These bindings deconstruct from ancestor paths already in scope + +3. **The hard part**: Determining *how* to bind a deeply nested path + - `p$106$1$1` needs `(deconstruct p$106$1 1)` + - But `p$106$1` needs `(deconstruct p$106 1)` first + - Must emit a chain of `let` bindings in the right order + +#### Assessment + +The difficulty of implementing Approach 3 in `tpmc_translate.c` suggests that fixing this in the DFA construction phase (`tpmc_match.c`) might be cleaner - ensuring comparisons only appear in the state machine after their required bindings have been established by prior constructor matches. + +### Approach 4: Sub-pattern Ordering + +When expanding a constructor pattern into sub-patterns (`makeSubPatternMatrix()`), ensure that sub-patterns containing comparisons are ordered after sub-patterns containing the variables they reference. + +## Related Code Locations + +- `src/tpmc_logic.c`: + - `replaceVarPattern()` - creates comparison patterns + - `replaceComparisonRule()` - processes a rule to identify repeated variables + +- `src/tpmc_match.c`: + - `mixture()` - main pattern matching algorithm, contains the current heuristic + - `columnHasComparisons()` - checks if a column contains comparison patterns + - `findFirstConstructorColumn()` - selects which column to process + - `makeSubPatternMatrix()` - expands constructor patterns into sub-patterns + +- `src/tpmc_translate.c`: + - `translateComparisonArcToTest()` - generates the equality test code + - `addFreeVariablesRequiredByPattern()` - adds comparison dependencies to free variables + +## Recommended Implementation: Approach 2, Mechanism B + +### Overview + +Track the required binding path in each comparison, and defer comparisons whose requirements aren't yet met. + +### Data Structure Change + +In `src/tpmc.yaml`, add a `requiredPath` field to `TpmcComparisonPattern`: + +```yaml +TpmcComparisonPattern: + data: + previous: TpmcPattern + current: TpmcPattern + requiredPath: HashSymbol=NULL # ADD THIS +``` + +This field stores the path of the first occurrence (the binding that must exist before the comparison is valid). + +### Code Changes + +#### 1. `src/tpmc_logic.c` - Record Required Path + +In `replaceVarPattern()`, after creating the comparison, record the path that must be bound: + +```c +static TpmcPattern *replaceVarPattern(TpmcPattern *pattern, + TpmcPatternTable *seen) { + TpmcPattern *other = NULL; + if (getTpmcPatternTable(seen, pattern->pattern->val.var, &other)) { + // ... existing error check for assignment ... + TpmcPatternValue *val = makeTpmcPatternValue_Comparison(other, pattern); + int save = PROTECT(val); + TpmcPattern *result = newTpmcPattern(val); + // NEW: Record the path that must be bound before this comparison + val->val.comparison->requiredPath = other->path; + UNPROTECT(save); + return result; + } + // ... rest of function ... +} +``` + +#### 2. `src/tpmc_match.c` - Check Comparison Readiness + +Add a helper to check if a comparison's required path is available: + +```c +static bool comparisonIsReady(TpmcPattern *pattern, TpmcMatrix *matrix) { + if (pattern->pattern->type != TPMCPATTERNVALUE_TYPE_COMPARISON) { + return true; // Not a comparison, always ready + } + HashSymbol *required = pattern->pattern->val.comparison->requiredPath; + if (required == NULL) { + return true; // No requirement recorded + } + // Check if required path is a column header (root-level binding) + for (Index x = 0; x < matrix->width; x++) { + TpmcPattern *top = getTpmcMatrixIndex(matrix, x, 0); + if (top->path == required) { + return true; // Required path is at root level + } + } + return false; // Required path is nested, not yet available +} +``` + +Modify `columnHasComparisons()` to only count "ready" comparisons: + +```c +static bool columnHasReadyComparisons(int x, TpmcMatrix *matrix) { + for (Index y = 0; y < matrix->height; y++) { + TpmcPattern *p = getTpmcMatrixIndex(matrix, x, y); + if (patternIsComparison(p) && comparisonIsReady(p, matrix)) { + return true; + } + } + return false; +} +``` + +Modify `findFirstConstructorColumn()` to treat non-ready comparisons as wildcards: + +```c +static bool patternIsActionable(TpmcPattern *pattern, TpmcMatrix *matrix) { + // Wildcards are not actionable + if (patternIsWildCard(pattern)) { + return false; + } + // Non-ready comparisons are treated as wildcards for column selection + if (patternIsComparison(pattern) && !comparisonIsReady(pattern, matrix)) { + return false; + } + return true; +} + +static int findFirstActionableColumn(TpmcMatrix *matrix) { + for (Index x = 0; x < matrix->width; x++) { + if (patternIsActionable(getTpmcMatrixIndex(matrix, x, 0), matrix)) { + return x; + } + } + cant_happen("findFirstActionableColumn failed"); +} +``` + +Update `mixture()` to use the new function and remove the column 0 fallback: + +```c +// Find first column with an actionable pattern (constructor, literal, or ready comparison) +int firstConstructorColumn = findFirstActionableColumn(M); +// No fallback needed - non-ready comparisons are skipped by findFirstActionableColumn +``` + +### How This Fixes the Bug + +For pattern `(mul(x, mul(num(1), x)))`: + +1. First `x` is at path `p$106$0`, second `x` at path `p$106$1$1` +2. Comparison is created with `requiredPath = p$106$0` +3. Initially, the matrix has column `p$106` - neither `p$106$0` nor `p$106$1$1` are top-level +4. `comparisonIsReady()` returns `false` since `p$106$0` is not a column header +5. The comparison doesn't trigger column 0 fallback +6. Algorithm processes `p$106` first, expanding to columns `p$106$0` and `p$106$1` +7. Now `p$106$0` IS a column header - `comparisonIsReady()` returns `true` +8. The comparison can now safely execute because `p$106$0` (the binding) will be processed + +### Edge Cases to Consider + +1. **Multiple occurrences (>2)**: Initially restrict to exactly 2 occurrences of a variable per pattern. Add explicit rejection in `replaceVarPattern()` if a variable is seen a third time. Can revisit later to support more complex cases. + +## Test Cases + +Working cases (for reference): + +- `tests/fn/test_pseudo_unification.fn` - comparison across different columns +- Pattern `(mul(mul(num(1), x), x))` - first `x` is deeper, works correctly + +Broken case (now fixed): + +- `tests/fn/bug_unification.fn` - comparison where second occurrence is deeper +- Pattern `(mul(x, mul(num(1), x)))` - second `x` is deeper + +## References + +- `docs/lambda-conversion.md` - Contains walkthrough of an earlier comparison bug fix +- `docs/agent/tpmc.md` - TPMC overview documentation +- Pettersson 1992 paper (`docs/pettersson92.pdf`) - Original algorithm (does not cover comparisons) + +## Implemented Fix + +The investigation revealed **two separate bugs** that combined to cause the failure: + +### Bug 1: Column Selection Didn't Defer Non-Ready Comparisons + +The original heuristic fell back to column 0 when comparisons existed, but this didn't handle cases where the required binding was nested within the same column. + +**Fix in `src/tpmc_match.c`:** + +1. Added `comparisonIsReady()` - checks if a comparison's `requiredPath` is a current column header +2. Added `patternIsActionable()` - returns false for wildcards and non-ready comparisons +3. Added `topRowHasNoActionablePatterns()` - replaces `topRowOnlyVariables()` to handle non-ready comparisons in the Variable Rule +4. Added `findFirstActionableColumn()` - replaces `findFirstConstructorColumn()`, skipping non-actionable patterns +5. Removed the column 0 fallback hack from `mixture()` + +### Bug 2: Comparison's `current` Path Was Added to Free Variables + +When processing comparisons for substitution, the `current` pattern (second occurrence) was being processed, which added its path to the substitutions map. This caused the path to appear in free variables even when the body didn't use it. + +**Fix in `src/tpmc_logic.c`:** + +Changed `collectComparisonSubstitutions()` to NOT process `current` for substitutions: + +```c +static TpmcPattern *collectComparisonSubstitutions(TpmcPattern *pattern, + SymbolMap *substitutions) { + // Process previous to collect substitutions - this is where the variable + // name should be bound (first occurrence) + TpmcPattern *previous = pattern->pattern->val.comparison->previous; + pattern->pattern->val.comparison->previous = + collectPatternSubstitutions(previous, substitutions); + // Note: Do NOT process current for substitutions. + // The current is only used for the equality comparison in the DFA, + // not for substitution into the body. + return pattern; +} +``` + +### Supporting Changes + +**`src/tpmc.yaml`:** + +- Added `requiredPath: HashSymbol=NULL` to `TpmcComparisonPattern` + +**`src/tpmc_logic.c`:** + +- Set `requiredPath = previous->path` in `renameComparisonPattern()` (after paths are assigned) +- Added rejection for >2 occurrences of the same variable in `replaceVarPattern()` + +**`src/tpmc_match.c`:** + +- Added `isAncestorPath()` helper for path relationship checking +- Modified `addFreeVariablesRequiredByPattern()` to only add comparison dependency if previous is NOT an ancestor of current +- Added handling for `TPMCPATTERNVALUE_TYPE_COMPARISON` in `arcsAreExhaustive()` - comparison arcs are now skipped when checking constructor exhaustiveness, since they are guards rather than constructor cases + +### Why Both Fixes Were Necessary + +- Bug 1 alone would still fail because `p$106$1$1` was appearing as a free variable at the root state +- Bug 2 alone would still fail because the column selection wasn't deferring the comparison until its required binding was available +- Together, the fixes ensure that (a) comparisons are deferred until ready, and (b) only the necessary paths appear in free variables + +### Fixed TPMC Graph + +```mermaid +--- +title: fixed +--- +flowchart TD +T196("p$106
[]
(arcs 2)") +T197("p$106$0
[p$106$1 p$106 p$106$0]
(arcs 2)") +T198("p$106$1
[p$106$1 p$106$0$0 p$106 p$106$0$1 p$106$0]
(arcs 3)") +T199("p$106$0$0
[p$106$0$0 p$106$0$1 p$106$0]
(arcs 2)") +T200("p$106$0$0$0
[p$106$0$1 p$106$0$0$0 p$106$0]
(arcs 2)") +F192("(begin 1)
[p$106$0$1]") +T200 --"p$106$0$0$0:1
[p$106$0$1]"--> F192 +F193("(begin 2)
[p$106$0]") +T200 --"p$106$0$0$0:_
[p$106$0]"--> F193 +T199 --"p$106$0$0:num(p$106$0$0$0:_)
[p$106$0$1 p$106$0]"--> T200 +T199 --"p$106$0$0:_
[p$106$0]"--> F193 +T198 --"p$106$1:p$106$0$1:_==p$106$1:var x
[p$106$0$0 p$106$0$1 p$106$0]"--> T199 +T201("p$106$1$0
[p$106 p$106$1$0 p$106$0]
(arcs 2)") +T202("p$106$1$0$0
[p$106$1$0$0 p$106 p$106$0]
(arcs 2)") +T202 --"p$106$1$0$0:1
[p$106$0]"--> F193 +F194("(begin 3)
[p$106]") +T202 --"p$106$1$0$0:_
[p$106]"--> F194 +T201 --"p$106$1$0:num(p$106$1$0$0:_)
[p$106 p$106$0]"--> T202 +T201 --"p$106$1$0:_
[p$106]"--> F194 +T198 --"p$106$1:mul(p$106$1$0:_, p$106$1$1:_)
[p$106 p$106$0]"--> T201 +T198 --"p$106$1:_
[p$106]"--> F194 +T197 --"p$106$0:mul(p$106$0$0:_, p$106$0$1:_)
[p$106$1 p$106]"--> T198 +T203("p$106$1
[p$106$1 p$106 p$106$0]
(arcs 2)") +T202 --"p$106$1$0$0:1
[p$106$0]"--> F193 +T202 --"p$106$1$0$0:_
[p$106]"--> F194 +T201 --"p$106$1$0:num(p$106$1$0$0:_)
[p$106 p$106$0]"--> T202 +T201 --"p$106$1$0:_
[p$106]"--> F194 +T203 --"p$106$1:mul(p$106$1$0:_, p$106$1$1:_)
[p$106 p$106$0]"--> T201 +T203 --"p$106$1:_
[p$106]"--> F194 +T197 --"p$106$0:_
[p$106$1 p$106]"--> T203 +T196 --"p$106:mul(p$106$0:_, p$106$1:_)
[]"--> T197 +T196 --"p$106:_
[]"--> F194 +``` + +### Why the Fixed Graph is Smaller + +The fixed graph has **8 test states** compared to the buggy graph's **12 test states** (33% reduction). This improvement is a direct consequence of fixing Bug 2 (the free variable propagation issue). + +**Root cause of state explosion:** + +In the buggy code, `collectComparisonSubstitutions()` processed both `previous` and `current` of a comparison pattern. This caused `p$106$1$1` (the `current` pattern's path) to be incorrectly added to free variable sets throughout the state machine. + +Compare the root arc in both graphs: + +**Buggy**: + +```mermaid +flowchart LR +T196("p$106
[]
(arcs 2)") +T197("p$106$0
[p$106$1 p$106 p$106$0]
(arcs 2)") +T196 --"p$106:mul...
[p$106$1$1]"--> T197 +``` + +**Fixed**: + +```mermaid +flowchart LR +T196("p$106
[]
(arcs 2)") +T197("p$106$0
[p$106$1 p$106 p$106$0]
(arcs 2)") +T196 --"p$106:mul...
[]"--> T197 +``` + +The spurious `[p$106$1$1]` is a path that doesn't even exist yet at T196 (p$106). + +**Why spurious free variables cause state explosion:** + +TPMC uses free variables to determine which states can be merged during DFA construction. When incorrect variables pollute free variable sets: + +1. States that should be structurally identical now have **different** free variable sets. +2. This **prevents state merging** during DFA minimization. +3. The algorithm maintains distinct execution paths for what should be shared logic. + +In the buggy graph, states T202-T205 form a separate chain that couldn't be merged with similar states elsewhere. In the fixed graph, states are reused more efficiently because their free variable sets correctly reflect only the variables actually needed. + +**Conclusion:** The fix removed "noise" from free variable tracking, allowing DFA minimization to work properly. This is a serendipitous optimization - the fix was required for correctness, but it also improved code generation efficiency. + +## Bug 4: Non-Ready Comparisons Creating Arcs + +### Symptom + +After fixing Bugs 1-3, a new failure appeared with more complex patterns involving pseudo-unification: + +```fn +fn broken { + (add(num(0), a)) | + (add(a, num(0))) { 2 } + (add(num(a), sub(num(0), num(a)))) | + (add(sub(num(0), num(a)), num(a))) { 0 } + (_) { 1 } +} +``` + +Error: `undefined variable p$106$0$1$0` + +### Root Cause + +When `mixture()` selects a column for processing (e.g., column `$1$0`), it correctly uses `findFirstActionableColumn()` to skip non-ready comparisons when choosing which column to process. However, once a column is selected, the loop that creates arcs for patterns in that column used `!patternIsWildCard(c)` as its filter. + +This meant that if column `$1$0` was selected because row 1 had an actionable pattern like `num(0)`, a non-ready comparison in row 2 of the same column would still get an arc created for it. That arc would then list the comparison's `requiredPath` (e.g., `p$106$0$1$0`) in its free variables - but that path hadn't been deconstructed yet. + +### The Fix + +The fix required two changes in `src/tpmc_match.c`: + +**Part 1: Skip non-ready comparisons in arc creation** + +The `mixture()` function's arc creation loop was changed from: + +```c +if (!patternIsWildCard(c)) { +``` + +to: + +```c +if (patternIsActionable(c, M)) { +``` + +The `patternIsActionable()` function already correctly handles both wildcards AND non-ready comparisons by returning `false` for both. This ensures non-ready comparisons don't get their own arcs with unbound free variables. + +**Part 2: Include non-ready comparisons in wildcard path** + +The `findWcIndices()` function, which collects row indices for the default/wildcard arc, was updated to also include non-ready comparisons: + +```c +static IntArray *findWcIndices(TpmcPatternArray *N, TpmcMatrix *M) { + // ... + while (iterateTpmcPatternArray(N, &row, &candidate, NULL)) { + if (patternIsWildCard(candidate)) { + pushIntArray(wcIndices, row - 1); + } + // Also include non-ready comparisons + else if (patternIsComparison(candidate) && + !comparisonIsReady(candidate, M)) { + pushIntArray(wcIndices, row - 1); + } + } + // ... +} +``` + +Without Part 2, non-ready comparisons were being lost entirely - they weren't getting arcs (correct) but they also weren't being included in the wildcard path (bug), so the rows containing pseudo-unification patterns never got propagated into the recursive `match()` call. + +When the algorithm recurses deeper and the required path eventually becomes a column header, the comparison will become "ready" and get its own arc at that point. + +## Bug 5: Comparisons Grouping With Constructors During Row Partitioning + +### Symptom + +After fixing Bugs 1-4, a new failure appeared with pseudo-unification patterns: + +```fn +fn simplify { + (div(num(a), num(b))) { num(a / b) } + (div(x, x)) { num(1) } + (x) { x } +} +``` + +Test case `tests/fn/bug_unifictation4.fn`: + +- Input: `simplify(div(num(1), var("x")))` +- Expected: `div(num(1), var("x"))` (no simplification, children differ) +- Actual: `num(1)` (incorrectly matched `div(x, x)` pattern) + +The pattern `(div(x, x))` was falsely matching when the two children were different types (`num` vs `var`). + +### Root Cause + +In `patternMatches()`, the logic for determining which patterns "match" a given constructor was too permissive for comparisons. The original code had: + +```c +|| isComparison +``` + +in several branches, which caused comparison patterns to match ANY constructor. This meant during row partitioning in `mixture()`: + +1. When processing rows for constructor `num`, the comparison row was grouped with it +2. Both rows ended up sharing the same final state body (`num(a/b)`) +3. The comparison was never actually evaluated + +### The Fix + +**Part 1: Fix `patternMatches()` to not group comparisons with constructors** + +Changed the logic so comparisons only match: + +- The same comparison pattern (for deduplication) +- Wildcards (which match everything) + +The key change was from `|| isComparison` to `!constructorIsComparison &&`: + +```c +// Before (wrong): +case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + return (pattern->pattern->val.constructor->tag == + constructor->pattern->val.constructor->tag) || + isComparison; // WRONG: comparison matches any constructor + +// After (correct): +case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + return !constructorIsComparison && + (pattern->pattern->val.constructor->tag == + constructor->pattern->val.constructor->tag); +``` + +**Part 2: Fix `comparisonIsReady()` to use prefix check** + +The comparison's `requiredPath` (e.g., `p$106$0`) may have been deconstructed, creating child paths as column headers (e.g., `p$106$0$0`, `p$106$0$1`). The comparison should become "ready" when any child of its required path exists. + +Added `pathIsPrefix()` helper: + +```c +static bool pathIsPrefix(HashSymbol *prefix, HashSymbol *full) { + const char *prefixStr = prefix->name; + const char *fullStr = full->name; + size_t prefixLen = strlen(prefixStr); + if (strncmp(prefixStr, fullStr, prefixLen) != 0) { + return false; + } + // Must be exact match or prefix followed by '$' + return fullStr[prefixLen] == '\0' || fullStr[prefixLen] == '$'; +} +``` + +Modified `comparisonIsReady()` to use this: + +```c +static bool comparisonIsReady(TpmcPattern *pattern, TpmcMatrix *matrix) { + // ... + for (Index x = 0; x < matrix->width; x++) { + TpmcPattern *top = getTpmcMatrixIndex(matrix, x, 0); + // Check if required path is a prefix of a column header + if (pathIsPrefix(required, top->path)) { + return true; + } + } + return false; +} +``` + +### Why Both Parts Were Necessary + +- Part 1 ensures comparisons are sent to the wildcard partition, not grouped with specific constructors +- Part 2 ensures the comparison becomes "ready" after the required path has been deconstructed (even though the exact path is no longer a column header) + +### How the Fix Works + +For pattern `(div(x, x))` matching `div(num(1), var("x"))`: + +1. First `x` is at `p$106$0`, second `x` at `p$106$1` +2. Comparison created with `requiredPath = p$106$0` +3. Initially, column is `p$106` - comparison not ready +4. Algorithm descends into `div`, creating columns `p$106$0` and `p$106$1` +5. Comparison IS now ready (column `p$106$0` exists) +6. Row partitioning for `num` constructor: + - Row 1 `(div(num(a), num(b)))`: has `num` in column 0 → groups with `num` + - Row 2 `(div(x, x))`: comparison in column 0 → goes to wildcard partition (not `num`) +7. Comparison row is correctly excluded from the `num` case +8. When wildcard path processes the comparison, it correctly tests `p$106$0 == p$106$1` and fails + +### Test Coverage + +Added `tests/fn/bug_unifictation4.fn`: + +```fn +let + typedef expr { num(number) | var(string) | div(expr, expr) } + + fn simplify { + (div(num(a), num(b))) { num(a / b) } + (div(x, x)) { num(1) } + (x) { x } + } +in + simplify(div(num(1), var("x"))) +// Expected output: div(num(1), var("x")) +``` diff --git a/docs/generated/anf.md b/docs/generated/anf.md index b3313598..b179acc8 100644 --- a/docs/generated/anf.md +++ b/docs/generated/anf.md @@ -4,13 +4,12 @@ A-Normal Form (ANF) structures to be converted to bytecode. ```mermaid flowchart LR -AnfSymbolTable --entries--> NULL -AnfIntTable --entries--> int AnfEnv --isLocal--> bool AnfEnv --isNameSpace--> bool +AnfEnv --isCapturing--> bool AnfEnv --nBindings--> int AnfEnv --nsEnvs--> AnfEnvArray -AnfEnv --table--> AnfIntTable +AnfEnv --table--> IntMap AnfEnv --next--> AnfEnv AexpLam --nArgs--> int AexpLam --letRecOffset--> int diff --git a/docs/generated/ast.md b/docs/generated/ast.md index 3bbfc408..124342bd 100644 --- a/docs/generated/ast.md +++ b/docs/generated/ast.md @@ -4,7 +4,6 @@ Abstract Syntax Tree (AST) structures generated by the parser. As this is close ```mermaid flowchart LR -AstIntTable --entries--> int AstProg --preamble--> AstDefinitions AstProg --nameSpaces--> AstNameSpaceArray AstProg --body--> AstExpressions @@ -28,8 +27,9 @@ AstExprAlias --name--> HashSymbol AstExprAlias --value--> AstExpression AstAnnotatedSymbol --symbol--> HashSymbol AstAnnotatedSymbol --originalImpl--> AstExpression -AstDefMacro --name--> HashSymbol -AstDefMacro --definition--> AstAltFunction +AstAnnotatedSymbol --isLazy--> bool +AstDefLazy --name--> HashSymbol +AstDefLazy --definition--> AstAltFunction AstTypeDef --typeSig--> AstTypeSig AstTypeDef --typeBody--> AstTypeBody AstTypeSig --symbol--> HashSymbol @@ -96,7 +96,7 @@ AstLookUpOrSymbol --lookUp--> AstLookUpSymbol AstDefinition --define--> AstDefine AstDefinition --multi--> AstMultiDefine AstDefinition --typeDef--> AstTypeDef -AstDefinition --macro--> AstDefMacro +AstDefinition --lazy--> AstDefLazy AstDefinition --alias--> AstAlias AstDefinition --blank--> void_ptr AstDefinition --builtinsSlot--> void_ptr @@ -136,9 +136,7 @@ AstExpression --error--> AstExpression AstPosition["enum AstPosition"] AstNameSpaceArray["AstNameSpaceArray[]"] --entries--> AstNameSpaceImpl AstFileIdArray["AstFileIdArray[]"] --entries--> file_id -AstStringArray["AstStringArray[]"] --entries--> string AstExpressionArray["AstExpressionArray[]"] --entries--> AstExpression -AstUTF8["AstUTF8[]"] --entries--> uchar ``` > Generated from src/ast.yaml by tools/generate.py diff --git a/docs/generated/cekfs.md b/docs/generated/cekfs.md index 0f69ed79..9b5fb675 100644 --- a/docs/generated/cekfs.md +++ b/docs/generated/cekfs.md @@ -33,7 +33,6 @@ Location --loc--> index Location --lineNo--> int Location --fileName--> string Vec["(Vec)"] --entries--> Value -CharVec["(CharVec)"] --entries--> schar Value --none--> void_ptr Value --stdint--> int Value --bigint--> BigInt diff --git a/docs/generated/lambda.md b/docs/generated/lambda.md index fc96672c..81b5bf30 100644 --- a/docs/generated/lambda.md +++ b/docs/generated/lambda.md @@ -4,20 +4,16 @@ Plain lambda structures generated by lambda conversion. ```mermaid flowchart LR -LamMacroSet --entries--> NULL -LamMacroArgsSet --entries--> NULL LamInfoTable --entries--> LamInfo LamAliasTable --entries--> LamTypeConstructorType LamExpTable --entries--> LamExp -LamAlphaTable --entries--> HashSymbol -LamLam --args--> LamVarList +LamLam --args--> SymbolList LamLam --exp--> LamExp -LamLam --isMacro--> bool -LamVarList --var--> HashSymbol -LamVarList --next--> LamVarList +LamLam --isLazy--> bool LamPrimApp --type--> LamPrimOp LamPrimApp --exp1--> LamExp LamPrimApp --exp2--> LamExp +LamPrimApp --replacement--> LamExp LamSequence --exp--> LamExp LamSequence --next--> LamSequence LamArgs --exp--> LamExp @@ -75,7 +71,7 @@ LamBindings --val--> LamExp LamBindings --next--> LamBindings LamContext --frame--> LamInfoTable LamContext --aliases--> LamAliasTable -LamContext --macros--> LamMacroSet +LamContext --macros--> SymbolSet LamContext --parent--> LamContext LamAmb --left--> LamExp LamAmb --right--> LamExp @@ -112,9 +108,6 @@ LamTypeConstructorInfo --needsVec--> bool LamTypeConstructorInfo --arity--> int LamTypeConstructorInfo --size--> int LamTypeConstructorInfo --index--> int -LamAlphaEnv --alphaTable--> LamAlphaTable -LamAlphaEnv --next--> LamAlphaEnv -LamAlphaEnv --nameSpaces--> LamAlphaEnvArray LamExp --amb--> LamAmb LamExp --apply--> LamApply LamExp --args--> LamArgs @@ -163,7 +156,6 @@ LamInfo --nameSpaceInfo--> LamContext LamInfo --nsId--> int LamPrimOp["enum LamPrimOp"] LamNameSpaceArray["LamNameSpaceArray[]"] --entries--> LamExp -LamAlphaEnvArray["LamAlphaEnvArray[]"] --entries--> LamAlphaEnv ``` > Generated from src/lambda.yaml by tools/generate.py diff --git a/docs/generated/minlam.md b/docs/generated/minlam.md new file mode 100644 index 00000000..93e07d56 --- /dev/null +++ b/docs/generated/minlam.md @@ -0,0 +1,76 @@ +# minlam + +Minimal AST after desugaring + +```mermaid +flowchart LR +MinExpTable --entries--> MinExp +MinLam --args--> SymbolList +MinLam --exp--> MinExp +MinExprList --exp--> MinExp +MinExprList --next--> MinExprList +MinPrimApp --type--> MinPrimOp +MinPrimApp --exp1--> MinExp +MinPrimApp --exp2--> MinExp +MinApply --function--> MinExp +MinApply --args--> MinExprList +MinLookUp --nsId--> int +MinLookUp --exp--> MinExp +MinIff --condition--> MinExp +MinIff --consequent--> MinExp +MinIff --alternative--> MinExp +MinCond --value--> MinExp +MinCond --cases--> MinCondCases +MinIntCondCases --constant--> MaybeBigInt +MinIntCondCases --body--> MinExp +MinIntCondCases --next--> MinIntCondCases +MinCharCondCases --constant--> character +MinCharCondCases --body--> MinExp +MinCharCondCases --next--> MinCharCondCases +MinMatch --index--> MinExp +MinMatch --cases--> MinMatchList +MinMatchList --matches--> MinIntList +MinMatchList --body--> MinExp +MinMatchList --next--> MinMatchList +MinIntList --item--> int +MinIntList --next--> MinIntList +MinLetRec --bindings--> MinBindings +MinLetRec --body--> MinExp +MinBindings --var--> HashSymbol +MinBindings --val--> MinExp +MinBindings --next--> MinBindings +MinAmb --left--> MinExp +MinAmb --right--> MinExp +MinAlphaEnv --alphaTable--> SymbolMap +MinAlphaEnv --next--> MinAlphaEnv +MinAlphaEnv --nameSpaces--> MinAlphaEnvArray +MinExp --amb--> MinAmb +MinExp --apply--> MinApply +MinExp --args--> MinExprList +MinExp --back--> void_ptr +MinExp --bigInteger--> MaybeBigInt +MinExp --bindings--> MinBindings +MinExp --callCC--> MinExp +MinExp --character--> character +MinExp --cond--> MinCond +MinExp --env--> void_ptr +MinExp --error--> void_ptr +MinExp --iff--> MinIff +MinExp --lam--> MinLam +MinExp --letRec--> MinLetRec +MinExp --lookUp--> MinLookUp +MinExp --makeVec--> MinExprList +MinExp --match--> MinMatch +MinExp --nameSpaces--> MinNameSpaceArray +MinExp --prim--> MinPrimApp +MinExp --sequence--> MinExprList +MinExp --stdint--> int +MinExp --var--> HashSymbol +MinCondCases --integers--> MinIntCondCases +MinCondCases --characters--> MinCharCondCases +MinPrimOp["enum MinPrimOp"] +MinNameSpaceArray["MinNameSpaceArray[]"] --entries--> MinExp +MinAlphaEnvArray["MinAlphaEnvArray[]"] --entries--> MinAlphaEnv +``` + +> Generated from src/minlam.yaml by tools/generate.py diff --git a/docs/generated/pratt.md b/docs/generated/pratt.md index 54c54cdc..fbd725c3 100644 --- a/docs/generated/pratt.md +++ b/docs/generated/pratt.md @@ -10,7 +10,7 @@ PrattTrie --character--> character PrattTrie --terminal--> HashSymbol PrattTrie --siblings--> PrattTrie PrattTrie --children--> PrattTrie -PrattBuffer --data--> PrattWVec +PrattBuffer --data--> WCharVec PrattBuffer --start--> wstring PrattBuffer --offset--> int PrattBufList --lineNo--> int @@ -42,8 +42,6 @@ PrattMixfixPattern --arity--> int PrattMixfixPattern --associativity--> PrattAssoc PrattMixfixPattern --startsWithHole--> bool PrattMixfixPattern --endsWithHole--> bool -PrattWVec["(PrattWVec)"] --entries--> character -PrattCVec["(PrattCVec)"] --entries--> schar PrattFixityConfig --op--> PrattParselet PrattFixityConfig --prec--> int PrattFixityConfig --originalImpl--> AstExpression @@ -51,9 +49,10 @@ PrattFixityConfig --hygienicFunc--> HashSymbol PrattFixityConfig --isBareSymbol--> bool PrattFixityConfig --export--> bool PrattFixityConfig --pattern--> PrattMixfixPattern +PrattFixityConfig --isLazy--> bool PrattFixityConfig --importNsRef--> int PrattFixityConfig --importNsSymbol--> HashSymbol -PrattValue --string--> PrattUnicode +PrattValue --string--> WCharArray PrattValue --number--> MaybeBigInt PrattValue --character--> character PrattValue --atom--> HashSymbol @@ -61,9 +60,8 @@ PrattAssoc["enum PrattAssoc"] PrattNumberState["enum PrattNumberState"] PrattStringState["enum PrattStringState"] PrattFixity["enum PrattFixity"] -PrattStrings["PrattStrings[]"] --entries--> PrattUnicode +PrattStrings["PrattStrings[]"] --entries--> WCharArray PrattParsers["PrattParsers[]"] --entries--> PrattParser -PrattUnicode["PrattUnicode[]"] --entries--> character PrattNsOpsArray["PrattNsOpsArray[]"] --entries--> PrattExportedOps ``` diff --git a/docs/generated/tpmc.md b/docs/generated/tpmc.md index 2bffaa6e..25f658a9 100644 --- a/docs/generated/tpmc.md +++ b/docs/generated/tpmc.md @@ -4,16 +4,15 @@ Term Pattern Matching Compiler types ```mermaid flowchart LR -TpmcVariableTable --entries--> NULL -TpmcSubstitutionTable --entries--> HashSymbol TpmcPatternTable --entries--> TpmcPattern TpmcStateTable --entries--> TpmcState TpmcMatchRules --rules--> TpmcMatchRuleArray -TpmcMatchRules --rootVariables--> TpmcVariableArray +TpmcMatchRules --rootVariables--> SymbolArray TpmcMatchRule --action--> TpmcState TpmcMatchRule --patterns--> TpmcPatternArray TpmcComparisonPattern --previous--> TpmcPattern TpmcComparisonPattern --current--> TpmcPattern +TpmcComparisonPattern --requiredPath--> HashSymbol TpmcAssignmentPattern --name--> HashSymbol TpmcAssignmentPattern --value--> TpmcPattern TpmcConstructorPattern --tag--> HashSymbol @@ -27,11 +26,11 @@ TpmcTestState --arcs--> TpmcArcArray TpmcFinalState --action--> LamExp TpmcState --refCount--> int TpmcState --stamp--> int -TpmcState --freeVariables--> TpmcVariableTable +TpmcState --freeVariables--> SymbolSet TpmcState --state--> TpmcStateValue TpmcArc --state--> TpmcState TpmcArc --test--> TpmcPattern -TpmcArc --freeVariables--> TpmcVariableTable +TpmcArc --freeVariables--> SymbolSet TpmcArcList --arc--> TpmcArc TpmcArcList --next--> TpmcArcList TpmcIntList --integer--> int @@ -48,11 +47,9 @@ TpmcStateValue --test--> TpmcTestState TpmcStateValue --final--> TpmcFinalState TpmcStateValue --error--> void_ptr TpmcMatchRuleArray["TpmcMatchRuleArray[]"] --entries--> TpmcMatchRule -TpmcVariableArray["TpmcVariableArray[]"] --entries--> HashSymbol TpmcPatternArray["TpmcPatternArray[]"] --entries--> TpmcPattern TpmcStateArray["TpmcStateArray[]"] --entries--> TpmcState TpmcArcArray["TpmcArcArray[]"] --entries--> TpmcArc -TpmcIntArray["TpmcIntArray[]"] --entries--> int TpmcMatrix["TpmcMatrix[][]"] --entries--> TpmcPattern ``` diff --git a/docs/generated/utils.md b/docs/generated/utils.md new file mode 100644 index 00000000..746fe9ff --- /dev/null +++ b/docs/generated/utils.md @@ -0,0 +1,25 @@ +# utils + +Common utility structures + +```mermaid +flowchart LR +SymbolSet --entries--> NULL +IntMap --entries--> int +SymbolMap --entries--> HashSymbol +FileId --stDev--> device +FileId --stIno--> inode +FileId --fileName--> SCharVec +SymbolList --symbol--> HashSymbol +SymbolList --next--> SymbolList +SCharVec["(SCharVec)"] --entries--> schar +WCharVec["(WCharVec)"] --entries--> character +StringArray["StringArray[]"] --entries--> string +WCharArray["WCharArray[]"] --entries--> character +UCharArray["UCharArray[]"] --entries--> byte +SCharArray["SCharArray[]"] --entries--> schar +SymbolArray["SymbolArray[]"] --entries--> HashSymbol +IntArray["IntArray[]"] --entries--> int +``` + +> Generated from src/utils.yaml by tools/generate.py diff --git a/docs/lazy-operators.md b/docs/lazy-operators.md new file mode 100644 index 00000000..33436c52 --- /dev/null +++ b/docs/lazy-operators.md @@ -0,0 +1,454 @@ +# Lazy Operators Proposal + +The old `macro` syntax in the parser has now been replaced by `lazy fn` declarations which are more true to what the actual implementation is. It also frees up the `macro` keyword for a potential later attempt at true syntactic extensibility, but for now I'd like to return to a problem remaining after the [bespoke comparators](bespoke-equality.md) was completed. + +As mentioned, operators are bound to automatically generated lazy functions declared in the output AST at the same point that the operator declaration was encountered in the input. Those lazy functions have generated names that would not pass the parser (they contain a dollar symbol) so cannot be shadowed by later definitions. For example the user-defined (preamble.yaml) `==` is bound to `opLazy$1` so `1 == 1` gets expaded to `(opLazy$1 (λ () 1) (λ () 1))` where `opLazy$1` is letrec-bound as `(opLazy$1 (λ (x1 x2) (eq (x1) (x2))))` (`eq` is the primitive). + +I'd like to extend the use of the `lazy` keyword to also qualify operators. Any `lazy operator ...` declaration should retain the current behaviour, which is needed for short-circuiting operators like `and` and `or`, but operators without the `lazy` qualifier should bind directly to their implementation. + +As a concrete example: `operator "_==_" left 5 EQUALTO` without the `lazy` qualifier would directly wrap that AST `EQUALTO` symbol and `1 == 1` would expand to `(eq 1 1)`. + +## Things to watch out for + +1. The use of operators to wrap constructors like `@` required special handling by the parser, we need to preserve that behaviour. +2. Namespace qualification is also something to preserve. + +## Initial Assessment + +Pros: + +1. The type checker can recognize the types of those arguments to `eq` and any bespoke comparator can be invoked as it should be. +2. The lack of a named wrapper function means that beta reductions can be applied, opening the door to later constant-folding simplifications. + +Cons: + +1. non-lazy operators are not hygenic. That `EQUALTO` symbol could be shadowed by user declarations. + +However most operators can be declared lazy, it's only equality and arithmetic where having them non-lazy has benefit (other than efficiency). And we can make those AST symbols like `EQUALTO` as obscure as we like: `INTERNAL_EQUALTO` or similar, where the chance of accidental shadowing is negligeable. + +## Implementation Strategy + +### Summary + +The default behaviour of `operator` declarations changes from lazy (thunked) +to non-lazy (direct). A new `lazy operator` syntax retains the current +lazy/hygienic wrapping for operators that need short-circuit evaluation. + +For non-lazy operators the key design decision — motivated by bespoke +comparators — is to **not generate a wrapper function at all**. Instead, +lambda conversion resolves the original implementation symbol directly at +each call site. This puts `LamPrimApp` nodes where the type checker can see +them with concrete, monomorphic argument types, enabling bespoke comparator +lookup to succeed. + +### Why the wrapper must be eliminated (not just made non-lazy) + +The bespoke comparator system injects replacements on `LamPrimApp(EQ, ...)` +nodes during type checking. It calls `lookupComparator(type)` which requires +a concrete `TcTypeSig` — a bare type variable is not sufficient. + +If a wrapper function exists (lazy or otherwise), the `LamPrimApp` lives +inside the wrapper body where the argument types are non-generic type +variables (`α`). The type checker processes the wrapper definition once and +generalizes it to `∀α. α → α → bool`. By the time the call site +`opDirect$N(myStruct1, myStruct2)` is analyzed with concrete types, the +`LamPrimApp` has already been analyzed with `replacement = NULL` and is +never revisited. + +Eliminating the wrapper for non-lazy operators moves the `LamPrimApp` to +the call site where the argument types are concrete. For example +`1 == 1` would produce `LamPrimApp(EQ, 1, 1)` directly, and the type +checker would see `int` arguments, enabling `lookupComparator` to find the +appropriate bespoke comparator (or fall back to primitive equality). + +### Phase 1: YAML Schema Changes + +#### 1a. Add `isLazy` to `PrattFixityConfig` (`src/pratt.yaml`) + +Add a new field to the inline struct: + +```yaml +isLazy: bool=false +``` + +This is needed for export/import propagation and for the parselets to know +which code path to take when emitting AST nodes. + +#### 1b. Add `isLazy` to `AstAnnotatedSymbol` (`src/ast.yaml`) + +Add a field so that the laziness decision is carried through the AST to +lambda conversion: + +```yaml +AstAnnotatedSymbol: + data: + symbol: HashSymbol + originalImpl: AstExpression + isLazy: bool=false +``` + +This is the bridge between parser and lambda conversion: `convertAnnotatedSymbol` +will dispatch on this flag. + +#### 1c. Regenerate + +Run `make` to regenerate all code from the updated YAML schemas. + +#### 1d. Update all initializer sites + +All `PrattFixityConfig` literal initializers (e.g. `emptyConfig` in +`addOperator()`) must be extended with the new `isLazy` field. Similarly +any code that constructs `AstAnnotatedSymbol` needs the new argument. + +### Phase 2: Parser Changes (`src/pratt_parser.c`) + +#### 2a. Parse `lazy operator` syntax + +In the `definition()` function, the `TOK_LAZY` branch currently requires +`TOK_FN` to follow. Extend it to also accept `TOK_OPERATOR`: + +```c +} else if (match(parser, TOK_LAZY())) { + if (check(parser, TOK_OPERATOR())) { + match(parser, TOK_OPERATOR()); + res = operator(parser, /*isLazy=*/true); + } else { + consume(parser, TOK_FN()); + res = defLazy(parser); + } +``` + +This must be done in all three places where `definition()` appears +(top-level, namespace, export contexts). Note that `export lazy operator ...` +will also need handling in the export path. + +The plain `operator` path becomes: + +```c +} else if (match(parser, TOK_OPERATOR())) { + res = operator(parser, /*isLazy=*/false); +``` + +#### 2b. Thread `isLazy` through the operator functions + +Add a `bool isLazy` parameter to: + +- `operator()` (the static function that parses the pattern string) +- `operatorWithPattern()` (parses associativity, precedence, implementation) +- `addOperator()` (builds the record and wrapper definition) +- `addMixfixOperator()` (handles mixfix patterns) + +#### 2c. Conditional wrapper generation in `addOperator()` + +Currently `addOperator()` always calls `makeHygienicNaryOperatorDef()` which +calls `makeHygenicOperatorBody()` which emits `makeAstDefinition_Lazy(...)`. +Split this: + +- **If `isLazy`**: Keep current behaviour. Call `makeHygienicNaryOperatorDef()` + to emit `makeAstDefinition_Lazy(...)`. The wrapper name continues to be + generated by `makeLazyName()` (e.g. `opLazy$N`). +- **If not `isLazy`**: Do not generate a wrapper function. Return + `newAstDefinition_Blank(...)`. A `hygienicFunc` name is still generated + (for consistency in the `PrattFixityConfig` and for the lazy fallback + path if the operator is later re-declared lazy in an inner scope), but + no corresponding definition is emitted. + +#### 2d. Parselet AST emission + +The parselets (`userPrefix`, `userInfixCommon`, `userPostfix`, mixfix +variants) currently emit: + +```c +AstExpression *func = makeAstExpression_AnnotatedSymbol( + TOKPI(tok), fixityConfig->hygienicFunc, fixityConfig->originalImpl); +``` + +Update to pass the `isLazy` flag: + +```c +AstExpression *func = makeAstExpression_AnnotatedSymbol( + TOKPI(tok), fixityConfig->hygienicFunc, + fixityConfig->originalImpl, fixityConfig->isLazy); +``` + +The namespace `LookUp` wrapping (`if (fixityConfig->importNsRef >= 0)`) +remains unchanged — it ensures the inner expression resolves in the +defining namespace regardless of laziness. + +#### 2e. Store laziness flag in `PrattFixityConfig` + +Set `fixityConfig->isLazy = isLazy` in `addOperator()` alongside the other +fixity config fields. + +#### 2f. Export/import paths + +In `exportOp()`, the export-with-definition path (`export operator ...` and +`export lazy operator ...`) needs to accept the `lazy` qualifier: + +```c +} else if (match(parser, TOK_LAZY())) { + consume(parser, TOK_OPERATOR()); + // parse as lazy operator, then mark exported +``` + +In `mergeFixity()`, copy `source->isLazy` → `target->isLazy`. + +The import path (`importOp()`) requires no changes beyond the `mergeFixity` +copy since it doesn't re-parse the operator definition. + +### Phase 3: Lambda Conversion (`src/lambda_conversion.c`) + +#### 3a. `convertAnnotatedSymbol` — three-way dispatch + +Currently this function has two paths: constructor inlining and hygienic +wrapper fallback. Add a third path for non-lazy operators: + +```c +static LamExp *convertAnnotatedSymbol(AstAnnotatedSymbol *annotated, + LamContext *env) { + // Path 1: Constructor inlining (unchanged) + if (annotated->originalImpl->type == AST_EXPRESSION_TYPE_SYMBOL) { + HashSymbol *originalSym = + getAstExpression_Symbol(annotated->originalImpl); + LamExp *constructor = makeConstructor(originalSym, env); + if (constructor != NULL) { + return constructor; + } + // Path 2: Non-lazy — resolve original symbol directly + if (!annotated->isLazy) { + return newLamExp_Var(CPI(annotated), originalSym); + } + } + // Path 3: Lazy — use hygienic wrapper (existing behaviour) + return newLamExp_Var(CPI(annotated), annotated->symbol); +} +``` + +Path 2 is the key change. By returning `LamExp_Var(EQUALTO)` instead of +`LamExp_Var(opLazy$N)`, the symbol flows into `convertFunCall` → +`makePrimApp`, which recognizes `EQUALTO` as `eqSymbol()` and produces +`LamPrimApp(EQ, arg1, arg2)` directly at the call site. + +#### 3b. `convertFunCall` / `makePrimApp` — no changes needed + +`makePrimApp` already recognizes built-in symbols (`addSymbol()`, +`eqSymbol()`, etc.) and produces `LamPrimApp` nodes. With Path 2 above, +these symbols now arrive at the call site rather than being buried inside a +wrapper body. + +For non-built-in implementations (e.g. `factorial` for `_!`, `append` for +`_@@_`), `makePrimApp` returns NULL and `convertFunCall` falls through to +`makeApplication()`, producing a normal `LamApply(factorial, [arg])`. This +is correct — these are ordinary function calls, just without thunking. + +#### 3c. `convertAstLazy` — unchanged + +When the parser emits `AstDefinition_Lazy` (for lazy operators), lambda +conversion calls `convertAstLazy()` which registers the symbol in +`env->macros` and sets `isLazy=true` on the `LamLam`. Call sites for these +operators continue to thunk arguments. No changes needed. + +### Phase 4: Type Checker — Bespoke Comparators + +With the wrapper eliminated for non-lazy operators, `1 == 1` now produces +`LamPrimApp(EQ, 1, 1)` at the call site. The type checker's `analyzePrim()` +processes this directly: + +1. `analyzeComparison()` unifies both operands — gets concrete type (e.g. `int`) +2. `lookupComparator(int)` checks for `eq$int` — finds it or falls back to + primitive EQ +3. If a bespoke comparator exists, sets `prim->replacement` + +For user-defined types: `myStruct1 == myStruct2` produces +`LamPrimApp(EQ, myStruct1, myStruct2)`. The type checker sees the concrete +`TcTypeSig` for the struct type, `lookupComparator` finds `eq$myStruct`, +and the replacement is injected. + +No changes are needed in the type checker. The existing `analyzePrim` / +`analyzeComparison` / `lookupComparator` machinery works correctly once +the `LamPrimApp` appears at the call site with concrete types. + +### Phase 5: Preamble Updates (`src/preamble.fn`) + +Update operator declarations to use the new syntax. Operators that genuinely +need laziness get `lazy operator`; all others become plain `operator`: + +**Stay as `lazy operator`** (need short-circuit / thunking): + +- `_and_`, `_or_`, `_nand_`, `_nor_`, `_xnor_` — short-circuit boolean logic +- `_then_` — amb/backtracking (arguments must not be eagerly evaluated) +- `&_` (THUNK) — the whole point is to delay evaluation +- `here_` (callcc) — continuation capture semantics + +**Become plain `operator`** (strict, both arguments always evaluated): + +- `_==_`, `_!=_`, `_≠_`, `_>_`, `_<_`, `_<=_`, `_>=_`, `_<=>_` — comparisons +- `_+_`, `_-_`, `_*_`, `_/_`, `_%_`, `_**_` — arithmetic +- `-_`, `+_` — unary arithmetic +- `_@_` — cons (already bypassed via constructor inlining, but consistency) +- `not_` — boolean negation (strict) +- `_xor_` — strict boolean (all args evaluated) +- `_!` — factorial (strict) +- `_of_` — function composition (strict) +- `*_` (FORCE) — strict +- `_@@_` — append (strict) +- `<_`, `>_` — car/cdr (strict) + +Note: `NUMERICIDENTITY` (unary `+`) is currently declared as `lazy fn`. Since +the unary `+` operator would become non-lazy, `NUMERICIDENTITY` can be +changed from `lazy fn` to a regular `fn`. + +### Phase 6: Testing + +#### 6a. Syntax tests + +Add test cases for: + +- `operator "..." prec impl;` — non-lazy operator (new default) +- `lazy operator "..." prec impl;` — lazy operator (explicit) +- `export operator ...` and `export lazy operator ...` +- `import ns operators;` — importing a mix of lazy and non-lazy operators + +#### 6b. Semantic tests + +- Verify that `and`/`or` still short-circuit (lazy operators) +- Verify that arithmetic operators produce correct results (non-lazy operators) +- Verify that bespoke comparators (`eq$T`) trigger for `==` on user types +- Verify that `cons` (`@`) still works for pattern matching +- Verify namespace import/export preserves laziness flag + +#### 6c. Bespoke comparator tests + +Specific tests that would have failed with a wrapper approach: + +- Define a type with `eq$T`, use `==` on it, verify custom comparator is + called +- Use `==` on a type without `eq$T`, verify primitive equality is used +- Use `==` on a polymorphic function argument — verify it still works + (falls back to primitive equality since the type is a variable) + +#### 6d. Regression tests + +Run the full test suite (`make test`) after each phase to catch regressions. + +### Risk Assessment + +**Low risk:** + +- Parser changes are localized to `addOperator` and its callers. +- Type checker requires no changes. +- Preamble changes are mechanical (add/remove `lazy` keyword). + +**Medium risk:** + +- Lambda conversion change to `convertAnnotatedSymbol` is small (adding one + `if` branch) but sits on a critical path. Constructor inlining must + continue to take precedence over the non-lazy path. +- The `PrattFixityConfig` and `AstAnnotatedSymbol` schema changes will + regenerate code. All construction sites must be updated. +- Export/import paths need testing with the new `isLazy` flag to ensure + it propagates correctly across namespace boundaries. + +**Low concern (documented cons):** + +- Non-lazy operators lose hygiene. The `originalImpl` symbol (e.g. + `EQUALTO`) is resolved in the call-site scope (or the imported namespace + scope for imported operators). Mitigated by using internal names that + users are unlikely to shadow. + +**Namespace qualification note:** For imported non-lazy operators, the +`AstLookUp` wrapper ensures the `originalImpl` symbol resolves in the +defining namespace. `convertLookUp` evaluates the inner `AnnotatedSymbol` +in the imported namespace's `LamContext`, so `EQUALTO` resolves correctly +there. + +### Implementation Order + +1. Add `isLazy` field to `PrattFixityConfig` in `pratt.yaml` and to + `AstAnnotatedSymbol` in `ast.yaml`. Run `make` to regenerate. +2. Update all `PrattFixityConfig` initializer sites and + `AstAnnotatedSymbol` construction sites for the new field. +3. Thread `isLazy` parameter through `operator()` → + `operatorWithPattern()` → `addOperator()`. +4. In `addOperator()`, skip wrapper generation for non-lazy operators. +5. Update parselets to pass `isLazy` to `makeAstExpression_AnnotatedSymbol`. +6. Update `definition()` in all three contexts to parse `lazy operator`. +7. Update `exportOp()` to handle `export lazy operator`. +8. Update `mergeFixity()` to copy `isLazy`. +9. Update `convertAnnotatedSymbol` in `lambda_conversion.c` with the + three-way dispatch. +10. Update `preamble.fn` to use `lazy operator` where needed, plain + `operator` elsewhere. +11. Run `make test` and fix any failures. + +## Implementation Attempt: Problems Encountered + +An implementation following this strategy was attempted and subsequently +reverted. All code changes compiled cleanly, the parser accepted the new +`lazy operator` syntax, and many tests passed, but two test regressions +were identified: + +- `test_currying_complete.fn` — segfault or corrupted type error +- `test_over_application_nested.fn` — crash (exit code 134) + +Both tests pass on the original code and fail only with the changes +applied. + +### Root Cause: Type Checker GC Bug + +The segfault in `test_currying_complete.fn` was traced via GDB to +infinite recursion in `prune()` (`tc_analyze.c`), caused by a corrupted +`TcType` — specifically a function type whose `TcFunction` fields had +been reclaimed by the garbage collector. + +Enabling post-parser stress GC (`forceGcFlag = true` at `main.c` line +520) reproduced the crash deterministically, confirming a missing +`PROTECT` somewhere in the type checker rather than a logic error in the +new code paths. + +### Why the Changes Expose This Bug + +Previously, all operators went through wrapper functions. An expression +like `a + b` was converted to `FunCall(opLazy$N, [a, b])`, and the type +checker processed the single wrapper body (`fn(x, y) { ADDITION(x, y) }`) +with type variables. With the changes, each `a + b` call site directly +produces a `LamPrimApp(ADD, a, b)` node, so the type checker processes +many more `LamPrimApp` nodes with concrete types. This increased GC +pressure exposes a pre-existing missing-PROTECT bug in the type checker +that was previously unreachable in practice. + +### Key Observations + +- The crash requires at least 17 test functions in a single compilation + unit to trigger; fewer functions pass. This is consistent with a GC + pressure threshold rather than a logic error. +- The specific trigger is `test_curry_conditionals` (a polymorphic + `fn(cond, a, b) { if (cond) { a } else { b } }` partially applied), + but only when preceded by enough earlier definitions to raise GC + pressure. +- The crash occurs inside `analyzeApply` when pruning the result type of + a function application. The `TcType` object appears valid (recognized + as `TCTYPE_TYPE_FUNCTION`) but its underlying `TcFunction` struct has + been freed. +- The `test_over_application_nested.fn` failure was not investigated in + detail but may share the same root cause. + +### Recommended Next Steps + +1. Investigate and fix the missing `PROTECT` in the type checker + independently of this feature. Use `forceGcFlag = true` at `main.c` + line 520 (in debugging mode) to reproduce. A good starting point is + `analyzeApply` case 1 (single-argument application) where `res` is + unprotected after `UNPROTECT(save)` before the final `prune(res)` + call, and `analyzePrim` where `res` is never protected. +2. Once the type checker GC bug is fixed, re-attempt this + implementation. The changes themselves are straightforward and the + approach is sound. +3. The inliner fix (`inlinePrim` must also inline `prim->replacement`) + discovered during the attempt should be included in any future + implementation. Without it, bespoke comparator replacements containing + un-inlined `LAMEXP_TYPE_CONSTRUCTOR` nodes crash the desugarer. + +### Resolution - FIXED + +The bug was a missing call to `PROTECT` just before the recently added check for bespoke comparators in the EQ branch of `analyzePrim`. Previously it had been safe not to protect the initial result as it was immediately returned. diff --git a/docs/multi-occurrence-pseudo-unification.md b/docs/multi-occurrence-pseudo-unification.md new file mode 100644 index 00000000..d7493312 --- /dev/null +++ b/docs/multi-occurrence-pseudo-unification.md @@ -0,0 +1,231 @@ +# Multi-Occurrence Pseudo-Unification + +## Overview + +Currently, F♮ supports pseudo-unification where the same variable appearing twice in a pattern creates an equality constraint. For example: + +```fn +fn same_pair { + (a, a) { true } + (_, _) { false } +} +``` + +This document proposes extending support to three or more occurrences of the same variable in a pattern. + +This document is a consequence of significant improvements and bug fixes (Bugs 1-5) documented in [TPMC Comparison Column Ordering](bugs/tpmc-comparison-column-ordering.md). The fixes ensure that: + +1. Comparisons are deferred until their required bindings are available (`comparisonIsReady()`) +2. Comparison paths are correctly excluded from free variables during substitution (Bug 2 fix) +3. Comparisons don't incorrectly group with constructor patterns during row partitioning (Bug 5 fix) + +These fixes are **prerequisites** for multi-occurrence support. + +## Current Limitation + +The current implementation explicitly rejects patterns with more than two occurrences: + +```c +// src/tpmc_logic.c, lines 419-423 +if (other->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON) { + can_happen( + "variable '%s' appears more than twice in pattern at +%d %s", + pattern->pattern->val.var->name, I.lineNo, I.fileName); +} +``` + +## Use Cases + +Supporting 3+ occurrences would enable patterns like: + +```fn +// All three elements equal +fn all_same { + (a, a, a) { true } + (_, _, _) { false } +} + +// Nested structure with repeated variable +fn symmetric { + (node(a, x, a)) { true } // left and right children are equal + (_) { false } +} + +// Multiple equality constraints in algebraic simplification +fn simplify { + (mul(a, mul(a, a))) { pow(a, 3) } // a * a * a = a^3 + (x) { x } +} +``` + +## Proposed Implementation + +### Design Choice: All Compare to First + +When a variable appears N times, generate N-1 comparison patterns, each comparing to the **first** occurrence (the binding site). + +For pattern `(a, a, a)`: + +- 1st `a` at path `$0`: stored as binding site (VAR pattern) +- 2nd `a` at path `$1`: comparison `$1 == $0` (COMPARISON pattern with `previous = $0`, `requiredPath = $0`) +- 3rd `a` at path `$2`: comparison `$2 == $0` (COMPARISON pattern with `previous = $0`, `requiredPath = $0`) + +Both comparisons have `requiredPath = $0`, so they become ready at the same time. + +**Important**: All comparisons must point directly to the original VAR pattern, not to other COMPARISON patterns. This is critical because: + +1. **Bug 2 fix requirement**: `collectComparisonSubstitutions()` only processes `previous` (the binding site) for variable name substitution into the body. If `previous` points to another comparison instead of the original VAR, the variable name will be lost. + +2. **Consistency**: The `requiredPath` must always reference the actual binding location where the variable is bound, not an intermediate comparison. + +### Changes Required + +#### 1. Modify `replaceVarPattern()` in `src/tpmc_logic.c` + +Current logic (lines 406-433): + +```c +static TpmcPattern *replaceVarPattern(TpmcPattern *pattern, + TpmcPatternTable *seen, ParserInfo I) { + TpmcPattern *other = NULL; + if (getTpmcPatternTable(seen, pattern->pattern->val.var, &other)) { + if (other->pattern->type == TPMCPATTERNVALUE_TYPE_ASSIGNMENT) { + can_happen("cannot compare assignment (var %s) at +%d %s", + pattern->pattern->val.var->name, I.lineNo, I.fileName); + } + if (other->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON) { + // More than 2 occurrences of same variable not yet supported + can_happen( + "variable '%s' appears more than twice in pattern at +%d %s", + pattern->pattern->val.var->name, I.lineNo, I.fileName); + } + TpmcPatternValue *val = makeTpmcPatternValue_Comparison(other, pattern); + int save = PROTECT(val); + // Note: requiredPath is set later in renameComparisonPattern when paths + // are assigned + TpmcPattern *result = newTpmcPattern(val); + UNPROTECT(save); + return result; + } else { + setTpmcPatternTable(seen, pattern->pattern->val.var, pattern); + return pattern; + } +} +``` + +**Key observation**: The `seen` table is NOT updated after the second occurrence. When the second occurrence is encountered, `other` is the first occurrence (a VAR pattern), and a COMPARISON is created pointing to it. However, the `seen` table still maps the variable name to the original VAR pattern, not to the new COMPARISON. + +This means the current implementation **already has the correct structure** for multi-occurrence support - it just needs the error check removed. + +Proposed change: + +```c +if (other->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON) { + // Extract the original binding site (first occurrence) + // The 'other' here is itself a comparison, so we need to follow + // 'previous' to get the original VAR pattern + other = other->pattern->val.comparison->previous; +} +TpmcPatternValue *val = makeTpmcPatternValue_Comparison(other, pattern); +``` + +This ensures all comparisons point to the original VAR, not to an intermediate COMPARISON. + +### Testing + +Test cases to add: + +```fn +// tests/fn/test_multi_unification.fn + +// Three identical values +fn triple { + (a, a, a) { 0 } + (_, _, _) { 1 } +} + +// Four identical values +fn quad { + (a, a, a, a) { 0 } + (_, _, _, _) { 1 } +} + +// Mixed: some unified, some not +fn partial { + (a, a, b, b) { 0 } // pairs must match + (_, _, _, _) { 1 } +} + +// Nested with triple occurrence +fn nested_triple { + ([a, a, a]) { 0 } // list is a nest of pairs + (_) { 1 } +} + +// In algebraic simplification context +typedef expr { + num(number) | + mul(expr, expr) | + pow(expr, number) +} + +fn simplify_cubes { + (mul(a, mul(a, a))) { pow(a, 3) } + (mul(mul(a, a), a)) { pow(a, 3) } + (x) { x } +} +``` + +### Potential Complications + +1. **Readiness ordering**: With multiple comparisons, they may become ready at different times if the binding site is deeply nested. The existing `comparisonIsReady()` check (with `pathIsPrefix()` from Bug 5 fix) handles this correctly since each comparison independently checks if its `requiredPath` is a column header or has been deconstructed. + +2. **Free variable tracking**: With the Bug 2 fix, `collectComparisonSubstitutions()` only processes `previous` (the binding site) and explicitly does NOT process `current`. This is correct for multi-occurrence: only the binding site's path will be in free variables, not the comparison paths. Each comparison adds only the binding site to its dependencies. + +3. **Code generation**: Multiple comparisons generate multiple `if (eq ...)` tests. The order should not matter since they are all equality checks. Example for `(a, a, a)` with paths `$0, $1, $2`: + + ```scheme + (if (eq $1 $0) + (if (eq $2 $0) + + ) + ) + ``` + +4. **Row partitioning**: The Bug 5 fix ensures comparisons don't incorrectly group with constructor patterns. With multiple comparisons in a pattern, each comparison will be evaluated independently via `patternIsActionable()`, ensuring they all reach the wildcard partition until ready. + +**Critical validation needed**: Test that when a third occurrence creates a comparison pointing to the original VAR (not to the second comparison), the `requiredPath` is correctly set to the VAR's path, not to the second comparison's path. This is essential because `renameComparisonPattern()` sets `requiredPath = previous->path` - we need `previous` to be the VAR. + +## Implementation Steps + +1. **Verify `seen` table behavior**: Confirmed that the `seen` table is NOT updated after the second occurrence - it always maps to the first (VAR) pattern. + +2. **Modify `replaceVarPattern()`**: + - Remove the error check for `TPMCPATTERNVALUE_TYPE_COMPARISON` + - Add logic to extract `previous` from a comparison pattern to ensure all comparisons point to the original VAR + +3. **Verify `renameComparisonPattern()` correctness**: Ensure that when `requiredPath = previous->path` is set, `previous` is always a VAR pattern with a valid path, not a COMPARISON pattern. + +4. **Add comprehensive test cases** covering: + - Three identical values in tuple + - Four or more occurrences + - Nested patterns with multiple occurrences + - Mixed patterns with multiple independent equality constraints + - Edge case: all occurrences in different nesting levels + +5. **Run full test suite** to ensure no regressions from Bugs 1-5 fixes. + +## Risk Assessment + +**Low risk** given the bug fixes: + +- Bug 1-4 fixes ensure comparison readiness, row partitioning, and free variable tracking work correctly +- Bug 5 fix ensures comparisons don't group with constructors, which is independent of occurrence count +- The `seen` table already naturally points all occurrences to the first VAR pattern +- Main change is removing an artificial restriction rather than adding new logic + +**Validation focus**: + +- Ensure `previous` pointer chain doesn't create comparisons pointing to comparisons +- Verify `requiredPath` is set correctly for all N-1 comparisons +- Test patterns with deep nesting where binding site is nested deeper than some comparison sites diff --git a/docs/simple-lambda.md b/docs/simple-lambda.md new file mode 100644 index 00000000..7f8fa5f4 --- /dev/null +++ b/docs/simple-lambda.md @@ -0,0 +1,56 @@ +# Extreme Desugaring done ASAP + +The idea on this `simple-lambda` branch is to perform maximum desugaring +of the `lambda.yaml` constructs after type-checking. + +The reason we can't do it earlier than that is that the type checker requires +anonymous lambda application to be rewritten into a `let` for polymorphic type +checking, while desugaring does the opposite. There is also an "inline" +step after typechecking that resolves type constructors, we can't desugar before that +(but a later refactoring might unify inlining and desugaring). + +Anyway here is a list of the desugaring operations that are desired: + +1. `let*` becomes a nest of `let`. **done** +1. `let` in turn becomes an anonymous lambda. **done** +1. All typedefs are discarded. +1. `LamPrint` becomes an `apply` of the compiled printer to its argument (already done in the type-checker but could be moved out to this additional step). **done** +1. `typeof` is replaced by a string (already done in the type-checker). **done** +1. `Construct` replaced with simple vector operation. (`constructToMakeVec` in `anf_normalize.c`). **done** +1. `Deconstruct` replaced with simple vector operation. (`deconstructToPrimApp` in `anf_normalize.c`). **done** +1. `LamConstant` to integer (see the treatment of `LAMEXP_TYPE_CONSTANT` in + `anf_normalize.c`). **done** +1. `LamTypeConstructorInfo` reduced to `Construct` or `Constant` by `inline.c`. **done** +1. `MakeTuple` to `makeVec` (see `tupleToMakeVec` in `anf_normalize.c`) **done** +1. `tag` becomes `primApp` (see `tagToPrimApp` in `anf_normalize.c`). **done** +1. `tupleIndex` becomes `primApp` (see `tupleIndexToPrimApp` in `anf_normalize.c`). **done** +1. `typeDefs` stepped over and discarded (see treatment of `LAMEXP_TYPE_TYPEDEFS` in `anf_normalize.c`) **done** +1. `intList` has its extra fields discarded (see `convertIntList` in `anf_normalize.c`) **done** + +More speculative desugaring: + +1. There should only be `LamLookUp`, `LamLookUpSymbol` etc are redundant. Actually they are only used by typedefs. **done** +1. `LamPrimApp` becomes `apply` of a primOp. +1. ... + +We really want to push towards a pure minimal lambda representation. +The result should be represented as a new stage, `minlam.yaml` or similar, presenting a much smaller surface area for subsequent transformations and greatly +reducing the amount of code downstream. + +Later desugaring that can't be done here: + +1. During CPS conversion, `call/cc` can be replaced with simple function application: `(call/cc f)` becomes `((lambda (f k) (f k k)) f k)`. +1. During CPS conversion, `sequence` becomes a chain of continuations(?) + +## Approach + +1. Create a verbatim copy of `lambda.yaml` called `minlam.yaml` **done** +2. Rename all prefixes in `minlam.yaml` from `Lam` to `Min` **done** +3. Generate a visitor on `lambda.yaml` called `lambda_desugar.c` **done** +4. Modify the generator to perform a plain translation from `Lam*` types to the new `Min*` types. **done** +5. Update the pipeline in main to perform this transform, after the constructor inlining step, before ANF conversion and to pass the new tree downstream to `lambda_alphaconvert.c`. **done** +6. Update `lambda_alphaconvert.c` and `anf_normalize.c` to consume `Min*` types instead of `Lam*` types. **done** +7. Test everything still works. We will also need to update the so-far unused `anf_normalize_2.c` and `lambda_CpsT[ck].c` to use `Min*` instead of `Lam*`. **done** +8. Iterate on the individual desugaring steps outlined in the previous section using the new visitor to translate, removing the now unused type from minlam.yaml and updating all affected files to no longer perform unnecessary translations. + +This may seem slightly pointless since `anf_normalize.c` immediately transforms that tree and discards it in favour of the new structs in `anf.yaml`, but this work is actually more geared towards the alternative lambda transforms "branch" of the pipeline, the alpha conversion, cps conversion, closure conversion, beta-reduction etc. that will all benefit from a much simpler and smaller dataset. diff --git a/docs/tpmc-match-refactoring.md b/docs/tpmc-match-refactoring.md new file mode 100644 index 00000000..1b6b8630 --- /dev/null +++ b/docs/tpmc-match-refactoring.md @@ -0,0 +1,388 @@ +# Refactoring Recommendations for tpmc_match.c + +This document outlines proposed refactorings to improve maintainability of [src/tpmc_match.c](../../src/tpmc_match.c). + +## Overview + +The file is currently ~1035 lines implementing the TPMC match algorithm based on the Pettersson 1992 paper. While functional, several areas could benefit from restructuring. + +--- + +## 1. Extract Duplicate Arc Detection (High Priority) + +**Problem:** The duplicate-arc detection in `mixture()` (lines 862-914) is ~50 lines of deeply nested conditional code checking if an arc already exists for a given constructor. + +**Current code pattern:** + +```c +bool alreadyProcessed = false; +for (Index i = 0; i < testState->state->val.test->arcs->size; i++) { + TpmcArc *existingArc = testState->state->val.test->arcs->entries[i]; + if (c->pattern->type == existingArc->test->pattern->type) { + if (c->pattern->type == TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { + if (c->pattern->val.constructor->tag == + existingArc->test->pattern->val.constructor->tag) { + alreadyProcessed = true; + break; + } + } else if (c->pattern->type == TPMCPATTERNVALUE_TYPE_CHARACTER) { + // ... more nesting ... + } + // ... 6 more pattern types ... + } +} +``` + +**Proposed solution:** Extract to a helper function: + +```c +static bool arcExistsForPattern(TpmcArcArray *arcs, TpmcPattern *pattern) { + for (Index i = 0; i < arcs->size; i++) { + TpmcArc *existing = arcs->entries[i]; + if (patternsAreEquivalentForArc(pattern, existing->test)) { + return true; + } + } + return false; +} + +static bool patternsAreEquivalentForArc(TpmcPattern *a, TpmcPattern *b) { + if (a->pattern->type != b->pattern->type) return false; + + switch (a->pattern->type) { + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + return a->pattern->val.constructor->tag == b->pattern->val.constructor->tag; + case TPMCPATTERNVALUE_TYPE_CHARACTER: + return a->pattern->val.character == b->pattern->val.character; + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + return cmpMaybeBigInt(a->pattern->val.bigInteger, + b->pattern->val.bigInteger) == 0; + case TPMCPATTERNVALUE_TYPE_TUPLE: + return true; // All tuples of same arity are equivalent + case TPMCPATTERNVALUE_TYPE_COMPARISON: + return tpmcPatternEq(a, b); + default: + return false; + } +} +``` + +**Benefits:** + +- Reduces `mixture()` complexity +- Makes the arc-existence logic testable in isolation +- Clarifies intent with descriptive function name + +--- + +## 2. Introduce a Context Struct (Medium Priority) + +**Problem:** Several functions pass the same 6-8 parameters repeatedly: + +- `errorState` +- `knownStates` +- `stateTable` +- `unsafe` +- `testedPaths` +- `I` (ParserInfo) + +**Current signatures:** + +```c +static TpmcState *match(TpmcMatrix *matrix, TpmcStateArray *finalStates, + TpmcState *errorState, TpmcStateArray *knownStates, + TpmcStateTable *stateTable, bool *unsafe, + SymbolSet *testedPaths, ParserInfo I); + +static TpmcState *mixture(TpmcMatrix *M, TpmcStateArray *finalStates, + TpmcState *errorState, TpmcStateArray *knownStates, + TpmcStateTable *stateTable, bool *unsafe, + SymbolSet *testedPaths, ParserInfo I); +``` + +**Proposed solution:** Bundle into a context struct: + +```c +typedef struct TpmcMatchContext { + TpmcState *errorState; + TpmcStateArray *knownStates; + TpmcStateTable *stateTable; + bool *unsafe; + SymbolSet *testedPaths; + ParserInfo parserInfo; +} TpmcMatchContext; +``` + +**New signatures:** + +```c +static TpmcState *match(TpmcMatrix *matrix, TpmcStateArray *finalStates, + TpmcMatchContext *ctx); + +static TpmcState *mixture(TpmcMatrix *M, TpmcStateArray *finalStates, + TpmcMatchContext *ctx); +``` + +**Benefits:** + +- Shorter function signatures +- Easier to add new context fields later +- Groups related state together +- Reduces chance of parameter ordering mistakes + +**Considerations:** + +- Requires updating all internal functions +- Context struct would be stack-allocated in `tpmcMatch()` entry point + +--- + +## 3. Split mixture() into Smaller Functions (High Priority) + +**Problem:** `mixture()` is ~130 lines doing multiple distinct tasks: + +1. Column selection and extraction +2. Building constructor arcs (main loop) +3. Exhaustiveness checking +4. Building default/error arc + +**Proposed solution:** Extract into focused functions: + +```c +static TpmcState *mixture(TpmcMatrix *M, TpmcStateArray *finalStates, + TpmcMatchContext *ctx) { + int col = findFirstActionableColumn(M, ctx->testedPaths); + TpmcPatternArray *selectedColumn = extractMatrixColumn(col, M); + TpmcMatrix *remainingColumns = discardMatrixColumn(col, M); + + TpmcState *testState = makeEmptyTestState(selectedColumn->entries[0]->path); + setSymbolSet(ctx->testedPaths, selectedColumn->entries[0]->path); + + createConstructorArcs(testState, selectedColumn, remainingColumns, + finalStates, ctx); + + createDefaultArcIfNeeded(testState, selectedColumn, remainingColumns, + finalStates, ctx); + + return deduplicateState(testState, ctx->knownStates, ctx->stateTable); +} + +static void createConstructorArcs(TpmcState *testState, + TpmcPatternArray *selectedColumn, + TpmcMatrix *remainingColumns, + TpmcStateArray *finalStates, + TpmcMatchContext *ctx); + +static void createDefaultArcIfNeeded(TpmcState *testState, + TpmcPatternArray *selectedColumn, + TpmcMatrix *remainingColumns, + TpmcStateArray *finalStates, + TpmcMatchContext *ctx); +``` + +**Benefits:** + +- Each function has a single responsibility +- Easier to understand control flow +- Better for debugging (can set breakpoints on specific phases) + +--- + +## 4. Rename Single-Letter Variables (Easy Win) + +**Problem:** Variables named `N`, `M`, `MN` come from the Pettersson paper but are cryptic without that context. + +**Current names:** + +- `M` - the pattern matrix +- `N` - the selected column +- `MN` - the matrix minus the selected column + +**Proposed names:** + +- `patternMatrix` or just `matrix` (already used in some places) +- `selectedColumn` +- `remainingColumns` + +**Also consider:** + +- `c` → `candidatePattern` or `currentPattern` +- `I` → `parserInfo` (already partially done with context struct) + +**Benefits:** + +- Self-documenting code +- Reduces need to reference the paper for understanding + +--- + +## 5. Add Section Comments (Low Effort, Medium Value) + +**Problem:** The file has distinct logical sections but no visual separation. + +**Proposed solution:** Add banner comments: + +```c +// ============================================================================ +// Matrix Operations +// ============================================================================ + +static TpmcPatternArray *extractMatrixColumn(int x, TpmcMatrix *matrix) { ... } +static TpmcMatrix *discardMatrixColumn(Index column, TpmcMatrix *matrix) { ... } +static TpmcMatrix *extractMatrixRows(IntArray *indices, TpmcMatrix *matrix) { ... } +static TpmcMatrix *appendMatrices(TpmcMatrix *prefix, TpmcMatrix *suffix) { ... } + +// ============================================================================ +// Pattern Operations +// ============================================================================ + +static bool patternIsWildCard(TpmcPattern *pattern) { ... } +static bool patternIsComparison(TpmcPattern *pattern) { ... } +static bool patternMatches(TpmcPattern *constructor, TpmcPattern *pattern) { ... } +// ... + +// ============================================================================ +// State and Arc Operations +// ============================================================================ + +static TpmcState *makeEmptyTestState(HashSymbol *path) { ... } +static TpmcArc *makeTpmcArc(TpmcPattern *pattern, TpmcState *state) { ... } +// ... + +// ============================================================================ +// Core Algorithm (Pettersson 1992) +// ============================================================================ + +static TpmcState *match(...) { ... } +static TpmcState *mixture(...) { ... } +``` + +**Alternative:** Split into multiple files (`tpmc_matrix.c`, `tpmc_pattern.c`, etc.) - but this may be overkill for ~1000 lines. + +--- + +## 6. Pattern Operation Dispatch Table (Low Priority) + +**Problem:** Multiple `switch (pattern->pattern->type)` blocks repeat similar logic for each pattern type. + +**Locations:** + +- `patternMatches()` - lines 203-266 +- `makeSubPatternMatrix()` - lines 453-490 +- `arityOf()` - lines 378-390 +- `replacePatternComponentsWithWildCards()` - lines 509-551 + +**Proposed solution:** Create a dispatch table: + +```c +typedef struct PatternTypeOps { + int (*getArity)(TpmcPattern *); + bool (*matchesPattern)(TpmcPattern *constructor, TpmcPattern *pattern); + void (*populateMatrixRow)(TpmcMatrix *, int y, int arity, + TpmcPattern *, ParserInfo); + TpmcPattern *(*replaceComponents)(TpmcPattern *); +} PatternTypeOps; + +static PatternTypeOps patternOps[] = { + [TPMCPATTERNVALUE_TYPE_CONSTRUCTOR] = { + .getArity = constructorArity, + .matchesPattern = constructorMatches, + .populateMatrixRow = populateConstructorRow, + .replaceComponents = replaceConstructorComponents, + }, + [TPMCPATTERNVALUE_TYPE_TUPLE] = { ... }, + // ... +}; +``` + +**Benefits:** + +- Centralizes pattern-type-specific behavior +- Adding new pattern types only requires updating one place +- More extensible design + +**Considerations:** + +- Adds indirection +- May be over-engineering for current needs +- Some operations don't apply to all types (need NULL checks or no-op defaults) + +--- + +## 7. Simplify PROTECT/UNPROTECT Patterns (Low Priority) + +**Problem:** Many functions have 5-10 PROTECT calls creating visual noise. + +**Example from `mixture()`:** + +```c +int save = PROTECT(N); +PROTECT(MN); +PROTECT(testState); +// ... later in loop ... +int save2 = PROTECT(indicesMatchingC); +PROTECT(patternsMatchingC); +PROTECT(subPatternsMatchingC); +PROTECT(prefixMatrix); +PROTECT(newMatrix); +PROTECT(newFinalStates); +PROTECT(cPrime); +PROTECT(newState); +PROTECT(arc); +// ... +UNPROTECT(save2); +// ... +UNPROTECT(save); +``` + +**Possible solutions:** + +1. **Scoped protection helper** (if C allows): + +```c +#define PROTECTED_SCOPE(save) \ + for (int save = protectionStackTop(), _loop = 1; _loop; UNPROTECT(save), _loop = 0) +``` + +1. **Batch protection function**: + +```c +int protectMany(int count, ...) { + va_list args; + va_start(args, count); + int save = -1; + for (int i = 0; i < count; i++) { + void *obj = va_arg(args, void *); + if (i == 0) save = PROTECT(obj); + else PROTECT(obj); + } + va_end(args); + return save; +} +``` + +1. **Accept current pattern** - it's explicit and matches the rest of the codebase. + +**Recommendation:** This is low priority. The current pattern is verbose but clear and consistent with the rest of the project. + +--- + +## Implementation Order + +Suggested order based on effort/value ratio: + +1. **Rename variables** (Easy, immediate clarity improvement) +2. **Extract duplicate arc detection** (Medium effort, high value) +3. **Add section comments** (Easy, helps navigation) +4. **Split mixture()** (Medium effort, high value) +5. **Introduce context struct** (Medium effort, simplifies signatures) +6. **Dispatch table** (Higher effort, consider if adding new pattern types) +7. **PROTECT simplification** (Low priority, consider deferring) + +--- + +## Notes + +- All refactorings should maintain the existing test suite passing +- Consider doing one refactoring at a time with a commit after each +- The Pettersson paper reference in comments should be preserved for algorithm understanding diff --git a/docs/uncurry.md b/docs/uncurry.md new file mode 100644 index 00000000..674f652f --- /dev/null +++ b/docs/uncurry.md @@ -0,0 +1,10 @@ +# Uncurrying Scratchpad + +```scheme +; uncurried <==> curried +((λ (x y) body) arg) <==> ((λ (x) (λ (y) body)) arg) +``` + +$$ +\lambda.x_1.x_2\;e = \lambda.x_1\;(\lambda.x_2\;e) +$$ diff --git a/docs/unify_assignment.md b/docs/unify_assignment.md new file mode 100644 index 00000000..5f7d36de --- /dev/null +++ b/docs/unify_assignment.md @@ -0,0 +1,187 @@ +# Pseudo-Unification with Alias Patterns + +## Problem + +Patterns combining pseudo-unification (repeated variable) with alias +(`x=pattern`) are currently rejected: + +```fn +fn test { + (x, x=1) { true } // error: cannot compare assignment (var x) + (_, _) { false } +} +``` + +The intent is: match when both args are equal **and** the value is 1. + +## Where the Error Occurs + +The error comes from `replaceComparisonPattern()` in `src/tpmc_logic.c`, which +runs a left-to-right scan over each rule's patterns to detect repeated +variables and convert them into comparison patterns. + +For `(x, x=1)`: + +1. Pattern 0 (`x`): VAR("x") stored in `seen` table. +2. Pattern 1 (`x=1`): ASSIGNMENT with `name="x"`, `value=bigint(1)`. + `replaceAssignmentPattern()` looks up "x" in `seen`, finds the VAR, and + emits the error. + +The reverse `(x=1, x)` fails similarly: the assignment is stored first, then +`replaceVarPattern()` finds the assignment in `seen` and emits the same error. + +## Two Distinct Cases + +### Case A: `(x, x=1)` - VAR first, ASSIGNMENT second + +The second occurrence's name matches a previously-seen VAR. This should create +a comparison (assert equality) between the two argument positions, **and** the +second argument should additionally be matched against the inner pattern (`1`). + +### Case B: `(x=1, x)` - ASSIGNMENT first, VAR second + +The assignment is seen first, storing the binding. The second `x` is a plain +repeated variable that should compare against the assigned position. + +## Feasibility Assessment + +### Case A: `(x, x=1)` - Moderate Complexity + +In `replaceAssignmentPattern()`: + +- Currently: error if `name` already in `seen`. +- Needed: if the previous is a VAR, create a COMPARISON between the assignment's + position and the VAR's position, then continue processing the assignment's + inner value pattern normally. + +The tricky part is that the assignment pattern does two things simultaneously: + +1. Binds `x` to the current position (substitution for the body). +2. Matches the inner pattern `1` against the value. + +When a comparison is also needed, we need to generate **both** a comparison arc +(equality test) and the inner pattern match. The current TPMC representation +does not combine a comparison with an inner value pattern in a single pattern +node. + +**Possible approach**: transform the assignment into its inner value pattern +(stripping the alias, since the binding is already recorded in `seen`), and +separately inject a comparison. The assignment's inner value `1` becomes the +actual pattern for that position, and the comparison is added as a guard. +However, the current architecture processes comparisons and value patterns +through different column selection paths in `mixture()` (comparisons go through +the "actionable" check, value patterns go through constructor arcs). Combining +both in one matrix cell would require either: + +- A new composite pattern type (comparison + value), or +- Splitting the single pattern into two columns (comparison column + value + column), which would change the matrix dimensions and require restructuring. + +A simpler approach: keep the comparison as the matrix pattern (for the equality +guard) and let the inner literal `1` be handled by adding an additional row +constraint. This could work if the comparison arc's recursive `match()` call +includes the literal check, but currently comparisons are opaque guards without +sub-patterns. + +### Case B: `(x=1, x)` - Lower Complexity + +In `replaceVarPattern()`: + +- Currently: error if `other` is an ASSIGNMENT. +- Needed: extract the assignment's **path** (which will be set during renaming) + to create a comparison. The assignment pattern binds `x` to its position and + matches `1`. The second occurrence of `x` just needs to compare its position + against the first's position. + +The complication is that at `replaceComparisonPattern` time, paths haven't been +assigned yet (that happens in `renamePattern`). However, comparisons already +handle this: `renameComparisonPattern()` sets `requiredPath = previous->path` +**after** renaming. So the fix would be: + +```c +if (other->pattern->type == TPMCPATTERNVALUE_TYPE_ASSIGNMENT) { + // The assignment binds 'x' at its position. We need to compare + // our position against the assignment's position. Use the + // assignment pattern itself as 'previous' - renaming will assign + // it the correct path. + TpmcPatternValue *val = makeTpmcPatternValue_Comparison(other, pattern); + ... +} +``` + +But `renameComparisonPattern()` does `pattern->requiredPath = +pattern->previous->path`, and `previous` here would be the ASSIGNMENT pattern. +Since `renameAssignmentPattern()` delegates to `renamePattern(value, path)`, +the assignment pattern's own `path` field is set by `renamePattern()` before +descending. So `previous->path` would correctly be the assignment's position. + +This case is feasible with minimal changes to `replaceVarPattern()`. + +### Downstream Impact in `tpmc_match.c` + +The `patternMatches()` function has `cant_happen("patternMatches encountered +assignment")`, and several other places similarly reject assignments. However, +by the time `mixture()` runs, assignments have been processed by +`collectAssignmentSubstitutions()` which strips them down to their inner value +pattern. So assignments should never reach `tpmc_match.c` - they are resolved +during substitution collection. This means no changes are needed in +`tpmc_match.c` for Case B. + +For Case A, the question is whether the inner value pattern (e.g., literal `1`) +correctly survives through the comparison creation. If the assignment is +converted to a comparison, its inner value pattern must still be present in the +matrix for `mixture()` to match against. + +## Recommendation + +### Implement Case B first: `(x=pattern, x)` + +This is the lower-risk change: + +1. In `replaceVarPattern()`, when `other` is an ASSIGNMENT, create a + comparison with `previous = other` (the assignment pattern). +2. The renaming phase will assign paths correctly since assignment patterns + get their `path` set normally. +3. The substitution collection phase already handles assignments correctly. +4. No changes needed in `tpmc_match.c`. + +Estimated effort: small (a few lines in `replaceVarPattern()`). + +### Case A: `(x, x=pattern)` requires more thought + +The core difficulty is that the current TPMC pattern model assumes each matrix +cell is a single pattern serving one purpose: either a constructor/literal match +**or** a comparison guard. An assignment-after-variable needs both. + +Options: + +1. **Rewrite to Case B**: a pre-processing pass that normalizes `(x, x=1)` to + `(x=1, x)` by moving the assignment to the first occurrence. This reuses + Case B's implementation but requires detecting the situation and swapping + pattern structure before comparison replacement. + +2. **Composite pattern**: introduce a pattern type that combines a comparison + with an inner pattern. This is more invasive but architecturally cleaner. + +3. **Desugaring**: treat `(x, x=1)` as syntactic sugar for `(x=1, x)` at the + parser or lambda conversion level, before TPMC ever sees it. + +**Option 1 (rewrite to Case B)** is likely the most pragmatic. During the +`replaceComparisonPattern` pass, when `replaceAssignmentPattern()` finds its +name already in `seen` as a VAR: + +- Convert the current VAR (first occurrence) into the assignment (move the + binding and inner pattern to the first position). +- Convert the current assignment position into a plain comparison against the + first position. + +This effectively transforms `(x, x=1)` into `(x=1, x)` at the TPMC pattern +level. + +## Risk Assessment + +- **Case B alone**: low risk, minimal code change, straightforward testing. +- **Case A via rewrite**: moderate risk, needs careful handling of the `seen` + table state and pattern mutation, but avoids architectural changes. +- **Case A via composite pattern**: higher risk, touches `tpmc_match.c` + pattern dispatching, exhaustiveness checking, and code generation. diff --git a/docs/utils-proposal.md b/docs/utils-proposal.md new file mode 100644 index 00000000..6489d6e9 --- /dev/null +++ b/docs/utils-proposal.md @@ -0,0 +1,29 @@ +# Common Generated Utilities Proposal + +## Requirement + +Among many of the structures defined in the various `src/*.yaml` files there is a good deal of duplication of common types such as sets (hashes with no values), hashes from symbols to various primitives, arrays and vectors of integers, wchar_t, char etc. It would be more efficient to share common declarations of these basic types in a `src/utils.yaml` or similar. + +## Naive Solution + +Just create the declarations in `utils.yaml` and refer to them from other packages in their `external` sections. + +## Problems to Solve + +There is a convenience around objects that are identified as "self-initializing" +(`isSelfInitializing` in the generate package). They are objects whose constructors take no arguments. Generated constructors for other objects that +contain self-initializing objects can just create them directly, rather than +taking them as argument. This reduces unnecessary code. + +In order to do that the objects self-identify as self-initializing. + +If we are to incorporate them into other packages, the other packages would also like to know if they are self identifying, but the `external` section contains only +simple text (the C name of the object, the name of its print function etc.) + +## Proposed Solution + +Extend the `external` declarations to add a `newFn` field that both provides the name of the constructor and identifies the object as self-initializing. + +## Implementation + +Add an `isSelfInitilizing` override to `primitives` and have it return `True` if the type has a `newFn` (primitives are synonymous with "external"). Store the `newFn` too and make it available via a `getConstructorName` method. diff --git a/fn/1.fn b/fn/1.fn new file mode 100644 index 00000000..49bd7a50 --- /dev/null +++ b/fn/1.fn @@ -0,0 +1,2 @@ +// minimal code to allow dumping of the preamble with --dump-lambda etc. +1 == 1; \ No newline at end of file diff --git a/fn/ambutils.fn b/fn/ambutils.fn index dc36861e..fd0c1de7 100644 --- a/fn/ambutils.fn +++ b/fn/ambutils.fn @@ -14,6 +14,7 @@ fn one_of { } export operator "from_" 8 one_of; +export operator "one_" 8 one_of; fn some_of { ([]) { back } @@ -26,8 +27,11 @@ fn integers_from(n) { n then integers_from(n + 1) } +export operator "_..." 8 integers_from; + fn integers_between(lower, upper) { - require(lower <= upper); + !: lower <= upper; lower then integers_between(lower + 1, upper) } +export operator "_.._" 8 integers_between; diff --git a/fn/array.fn b/fn/array.fn index c674fe4c..5f87a944 100644 --- a/fn/array.fn +++ b/fn/array.fn @@ -9,7 +9,7 @@ print Array fn (pt, a = array(low, high, d) { fn helper { (n)) { switch(dic.lookup(n, d)) { - (some(v)) { + (just(v)) { pt(v); if (n < high - 1) { puts(", "); diff --git a/fn/barrels2.fn b/fn/barrels2.fn index 06bf2a2d..60054273 100644 --- a/fn/barrels2.fn +++ b/fn/barrels2.fn @@ -1,6 +1,8 @@ let link "ambutils.fn" as amb; - link "listutils.fn" as list; + import amb operators; + link "listutils.fn" as lst; + import lst operators; // A wine merchant has six barrels of wine and beer containing: // @@ -20,13 +22,13 @@ let fn barrels_of_fun() { let barrels = [30, 32, 36, 38, 40, 62]; - beer = amb.one_of(barrels); - wine = list.exclude([beer], barrels); - barrel_1 = amb.one_of(wine); - barrel_2 = amb.one_of(list.exclude([barrel_1], wine)); - purchase = amb.some_of(list.exclude([barrel_1, barrel_2], wine)); + beer = one barrels; + wine = barrels except [beer]; + wine_1 = one wine; + wine_2 = one wine except [wine_1]; + purchase = some wine except [wine_1, wine_2]; in - amb.require((barrel_1 + barrel_2) * 2 == list.sum(purchase)); + !: (wine_1 + wine_2) * 2 == total purchase; beer } in diff --git a/fn/derivative2.fn b/fn/derivative2.fn index 08338d57..7f65f7fb 100644 --- a/fn/derivative2.fn +++ b/fn/derivative2.fn @@ -36,7 +36,7 @@ let } fn simplify { - (x=num(_)) { x } + (x=num(_)) | (x=var(_)) { x } (add(a, num(0))) | (add(num(0), a)) { simplify(a) } @@ -45,11 +45,23 @@ let (add(num(a), add(x, num(b)))) | (add(add(x, num(b)), num(a))) | (add(add(num(b), x), num(a))) { simplify(add(num(a + b), x)) } + (add(num(a), sub(num(b), x))) | + (add(sub(num(b), x), num(a))) { simplify(sub(num(a + b), x)) } + (add(num(a), sub(x, num(b)))) | + (add(sub(x, num(b)), num(a))) { simplify(add(x, num(a - b))) } (add(a, num(n))) | (add(num(n), a)) { add(num(n), simplify(a)) } (add(a, b)) { add(simplify(a), simplify(b)) } + (sub(num(a), num(b))) { num(a - b) } (sub(a, num(0))) { simplify(a) } - (sub(a, num(n))) { sub(simplify(a), num(n)) } + (sub(num(a), sub(num(b), x))) { simplify(add(num(a - b), x)) } + (sub(num(a), sub(x, num(b)))) { simplify(sub(num(a + b), x)) } + (sub(num(a), add(num(b), x))) | + (sub(num(a), add(x, num(b)))) | + (sub(sub(num(a), x), num(b))) { simplify(sub(num(a - b), x)) } + (sub(sub(x, num(a)), num(b))) { simplify(sub(x, num(a + b))) } + (sub(add(num(a), x), num(b))) | + (sub(add(x, num(a)), num(b))) { simplify(sub(x, num(a + b))) } (sub(a, b)) { sub(simplify(a), simplify(b)) } (mul(num(0), _)) | (mul(_, num(0))) { num(0) } diff --git a/fn/dictutils.fn b/fn/dictutils.fn index f651b32d..c15ebf5d 100644 --- a/fn/dictutils.fn +++ b/fn/dictutils.fn @@ -102,7 +102,7 @@ fn balance { // #t -> Dict(#t, #u) -> Maybe(#u) fn lookup { (_, E) | (_, EE) { nothing } - (k, D(_, _, #(k, y), _)) { some(y) } + (k, D(_, _, #(k, y), _)) { just(y) } (k, D(_, a, #(y, _), b)) { if (k < y) { lookup(k, a) diff --git a/fn/heap.fn b/fn/heap.fn index 595a4f2f..393190e0 100644 --- a/fn/heap.fn +++ b/fn/heap.fn @@ -1,8 +1,6 @@ let typedef heap(#t) { E | T(number, #t, heap(#t), heap(#t)) } - typedef maybe(#t) { none | some(#t) } - fn merge { (E, h) | (h, E) { h } (h1=T(_, x, a1, b1), h2=T(_, y, a2, b2)) { @@ -33,7 +31,7 @@ let fn findMin { (E) { none } - (T(_, x, _, _)) { some(x) } + (T(_, x, _, _)) { just(x) } } fn deleteMin { @@ -55,7 +53,7 @@ let fn helper { (hp, lst) { switch(findMin(hp)) { - (some(min)) { + (just(min)) { helper(deleteMin(hp), min @ lst) } (none) { diff --git a/fn/import_dictionary.fn b/fn/import_dictionary.fn index 2210ef48..8ea3c762 100644 --- a/fn/import_dictionary.fn +++ b/fn/import_dictionary.fn @@ -5,7 +5,7 @@ let dd = dict.insert(1, "hello", dict.insert(2, "goodbye", dict.E)); in print(fn { - (maybe.some(s)) { s } + (maybe.just(s)) { s } (maybe.nothing) { "nothing" } }(dict.lookup(2, dd))); print(dd); diff --git a/fn/import_maybe.fn b/fn/import_maybe.fn index b9b236a1..bb46ca7c 100644 --- a/fn/import_maybe.fn +++ b/fn/import_maybe.fn @@ -2,7 +2,7 @@ let link "maybe.fn" as maybe; in print(fn { - (maybe.some(x)) { x } + (maybe.just(x)) { x } (maybe.nothing) { 0 } - }(maybe.some(1))) + }(maybe.just(1))) // maybe.nothing diff --git a/fn/ioutils.fn b/fn/ioutils.fn index dd815fca..0eadfd92 100644 --- a/fn/ioutils.fn +++ b/fn/ioutils.fn @@ -3,7 +3,7 @@ namespace fn with_output_to(filename, handler) { switch (open(filename, io_write)) { (success(filehandle)) { - let data = some(handler(filehandle)); + let data = just(handler(filehandle)); in close(filehandle); data; @@ -18,7 +18,7 @@ fn with_output_to(filename, handler) { fn with_input_from(filename, handler) { switch (open(filename, io_read)) { (success(filehandle)) { - let data = some(handler(filehandle)); + let data = just(handler(filehandle)); in close(filehandle); data; @@ -33,7 +33,7 @@ fn with_input_from(filename, handler) { fn with_buffer(handler) { switch (openmem()) { (success(filehandle)) { - let data = some(handler(filehandle)); + let data = just(handler(filehandle)); in close(filehandle); data; @@ -50,7 +50,7 @@ fn to_string(data) { fputv(buf, data); fgets(buf); })) { - (some(result)) { result } + (just(result)) { result } } } diff --git a/fn/lazyutils.fn b/fn/lazyutils.fn index c8af4e50..dcbf32af 100644 --- a/fn/lazyutils.fn +++ b/fn/lazyutils.fn @@ -2,7 +2,7 @@ let typedef lazy(#t, #v) { thunk(#t) | value(#v) } - macro THUNK(x) { thunk(fn () {x}) } + lazy fn THUNK(x) { thunk(fn () {x}) } operator "&_" 14 THUNK; fn FORCE { diff --git a/fn/liars2.fn b/fn/liars2.fn index 75842e1f..fa123091 100644 --- a/fn/liars2.fn +++ b/fn/liars2.fn @@ -1,13 +1,8 @@ let link "ambutils.fn" as amb; - import amb operator "from_"; - import amb operator "!:_"; // require + import amb operators; link "listutils.fn" as list; - import list operator "_except_"; - import list operator "_zip_"; - import list operator "_|>_"; // map - import list operator "_<>_"; // sortBy - import list operator "_::_"; // range + import list operators; // Five schoolgirls sat for an examination. Their parents—so they // thought—showed an undue degree of interest in the result. @@ -42,10 +37,10 @@ let !: (kitty == 2) xor (mary == 4); !: (mary == 4) xor (betty == 1); - ["Betty", "Ethel", "Joan", "Kitty", "Mary"] zip - [ betty, ethel, joan, kitty, mary ] <> - fn (#(_, a), #(_, b)) { a <=> b } |> - fn (#(x, _)) { x }; + ["Betty", "Ethel", "Joan", "Kitty", "Mary"] + zip [betty, ethel, joan, kitty, mary] + <> fn (#(_, a), #(_, b)) { a <=> b } + |> fn (#(x, _)) { x }; } in print liars() diff --git a/fn/listutils.fn b/fn/listutils.fn index d95c70d5..afb236cd 100644 --- a/fn/listutils.fn +++ b/fn/listutils.fn @@ -22,6 +22,12 @@ fn unique(lst) { in helper(lst, []) } +// distinct: list(#a) -> bool +fn distinct { + ([]) { true } + (h @ t) { not member(h, t) and distinct(t) } +} + // exclude: list(#t) -> list(#t) -> list(#t) fn exclude(items, lst) { let fn helper { @@ -228,6 +234,8 @@ fn sum(lst) { foldl(fn (elm, acc) { elm + acc }, 0, lst) } +export operator "total_" left 8 sum; + // product: list(number) -> number fn product(lst) { foldl(fn (elm, acc) { elm * acc }, 1, lst) @@ -240,7 +248,7 @@ fn zip(a, b) { export operator "_zip_" left 8 zip; -// zipwith: (#a -> #b -> #c) -> list(#a) -> list(#b) -> list(#c) +// zip_with: (#a -> #b -> #c) -> list(#a) -> list(#b) -> list(#c) fn zip_with(f, a, b) { let fn helper { (h1 @ t1, h2 @ t2, acc) { @@ -261,6 +269,15 @@ fn unzip { } } +export operator "unzip_" 8 unzip; + +// pairmap: (#a -> #c) -> (#b -> #d) -> #(#a, #b) -> #(#c, #d) +fn pairmap(l, r) { + fn (#(ls, rs)) { #(l(ls), r(rs)) } +} + +export operator "_&&_" left 9 pairmap; + // last: list(#a) -> #a unsafe fn last { ([a]) { a } diff --git a/fn/macro.fn b/fn/macro.fn index 837c49d6..c674dedb 100644 --- a/fn/macro.fn +++ b/fn/macro.fn @@ -5,10 +5,10 @@ let } operator "not_" 4 NOT; - macro AND(a, b) { if (a) { b } else { false } } + lazy fn AND(a, b) { if (a) { b } else { false } } operator "_AND_" left 3 AND; - macro OR(a, b) { if (a) { true } else { b } } + lazy fn OR(a, b) { if (a) { true } else { b } } operator "_OR_" left 3 OR; fn XOR { @@ -19,13 +19,13 @@ let } operator "_XOR_" left 3 XOR; - macro NAND(a, b) { NOT (a AND b) } + lazy fn NAND(a, b) { NOT (a AND b) } operator "_NAND_" left 3 NAND; - macro NOR(a, b) { NOT (a OR b) } + lazy fn NOR(a, b) { NOT (a OR b) } operator "_NOR_" left 3 NOR; - macro XNOR(a, b) { NOT (a XOR b) } + lazy fn XNOR(a, b) { NOT (a XOR b) } operator "_XNOR_" left 3 XNOR; fn a() { print("a called"); false } diff --git a/fn/maybe.fn b/fn/maybe.fn index a6b72357..8632dc50 100644 --- a/fn/maybe.fn +++ b/fn/maybe.fn @@ -1,29 +1,27 @@ namespace -typedef maybe(#t) { nothing | some(#t) } - // map: (#t -> #u) -> maybe(#t) -> maybe(#u) fn map { (_, nothing) { nothing } - (f, some(x)) { some(f(x)) } + (f, just(x)) { just(f(x)) } } // bind: maybe(#t) -> (#t -> maybe(#u)) -> maybe(#u) fn bind { - (some(x), f) { f(x) } + (just(x), f) { f(x) } (nothing, _) { nothing } } // // safediv: number -> number -> maybe(number) // fn safediv { // (_, 0) { nothing } -// (x, y) { some(x / y) } +// (x, y) { just(x / y) } // } // // // eval(expr) -> maybe(number) // // fn eval { -// (val(n)) { some(n) } +// (val(n)) { just(n) } // (div(x, y)) { // bind(eval(x), fn (n) { // bind(eval(y), fn (m) { @@ -36,7 +34,7 @@ fn bind { // // do notation // // fn eval { -// (val(n)) { return(n) } // return == some +// (val(n)) { return(n) } // return == just // (div(x, y)) { // do n <- eval(x) // a <- b rest == bind(b, fn(a) { rest }) // m <- eval(y) diff --git a/fn/monad.fn b/fn/monad.fn index bf60ff0b..6b47e096 100644 --- a/fn/monad.fn +++ b/fn/monad.fn @@ -10,19 +10,19 @@ fn safe_div { nothing } (x, y) { - some(x / y) + just(x / y) } } fn eval2 { - (val(n)) { some(n) } + (val(n)) { just(n) } (div(x, y)) { switch (eval2(x)) { (none) { none } - (some(vx)) { + (just(vx)) { switch (eval2(y)) { (none) { none } - (some(vy)) { safe_div(vx, vy) } + (just(vy)) { safe_div(vx, vy) } } } } @@ -32,12 +32,12 @@ fn eval2 { operator "_>>=_" left 12 fn (m, f) { switch (m) { (none) { none } - (some(v)) { f(v) } + (just(v)) { f(v) } } }; fn return { - (v) { some(v) } + (v) { just(v) } } fn eval { diff --git a/fn/pythagoreanTriples.fn b/fn/pythagoreanTriples.fn index 4282f1db..467035e4 100644 --- a/fn/pythagoreanTriples.fn +++ b/fn/pythagoreanTriples.fn @@ -1,18 +1,19 @@ let link "ambutils.fn" as amb; + import amb operators; fn pythagorean_triples() { let - z = amb.integers_from(1); - x = amb.integers_between(1, z); - y = amb.integers_between(x, z); + z = 1 ... ; + x = 1 .. z; + y = x .. z; in - amb.require(x**2 + y**2 == z**2); - [x, y, z] + !: x**2 + y**2 == z**2; + [z, y, x] } in { let triple = pythagorean_triples(); in print(triple); - amb.require( 20) // until + !: 500; } diff --git a/fn/queue.fn b/fn/queue.fn index 6766e1d3..4fa3497f 100644 --- a/fn/queue.fn +++ b/fn/queue.fn @@ -1,5 +1,4 @@ let - link "maybe.fn" as maybe; link "listutils.fn" as list; fn enq (t, #(head, tail)) { @@ -8,10 +7,10 @@ let fn deq { (#(h @ head, tail)) { - #(maybe.some(h), #(head, tail)) + #(just(h), #(head, tail)) } (x = #(_, [])) { - #(maybe.nothing, x) + #(nothing, x) } (#(_, tail)) { deq(#(list.reverse(tail), [])) diff --git a/fn/rewrite/README.md b/fn/rewrite/README.md index 591ee845..bd6da66a 100644 --- a/fn/rewrite/README.md +++ b/fn/rewrite/README.md @@ -1,18 +1,16 @@ # Rewrite -An exploratory sub-project to investigate re-writing F♯ in F♯. For -this to be practical we would need to target LLVM rather than a bytecode -interpreter. +An exploratory sub-project to investigate re-writing F♯ in F♯. For this to be practical we would need to target LLVM rather than a bytecode interpreter. -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. +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. -* [ceskf.fn](ceskf.fn) - The core CESKF machine. -* [infer.fn](infer.fn) - Type inference. -* [interpreter.fn](interpreter.fn) - A naïve lambda interpreter demo. -* [normalize.fn](normalize.fn) - ANF conversion. -* [petterson92.fn](petterson92.fn) - Pettersson's Term Pattern Matching Compiler algorithm. -* [pratt.fn](pratt.fn) - Pratt Parser. - * [pratt_lexer.fn](pratt_lexer.fn) - Lexer Support for the Parser. - * [pratt_sexpr.fn](pratt_sexpr.fn) - Target Symbolic Expressions for the parser. +* [`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. +* [`infer.fn`](infer.fn) - Type inference. +* [`interpreter.fn`](interpreter.fn) - A naïve lambda interpreter demo. +* [`normalize.fn`](normalize.fn) - ANF conversion. +* [`petterson92.fn`](petterson92.fn) - Pettersson's Term Pattern Matching Compiler algorithm. +* [`pratt.fn`](pratt.fn) - Pratt Parser. + * [`pratt_lexer.fn`](pratt_lexer.fn) - Lexer Support for the Parser. + * [`pratt_sexpr.fn`](pratt_sexpr.fn) - Target Symbolic Expressions for the parser. diff --git a/fn/rewrite/alphaconvert.fn b/fn/rewrite/alphaconvert.fn index d7af8244..3912b59b 100644 --- a/fn/rewrite/alphaconvert.fn +++ b/fn/rewrite/alphaconvert.fn @@ -1,73 +1,73 @@ namespace -link "expr.fn" as E; +link "minexpr.fn" as M; link "env.fn" as Env; link "../listutils.fn" as list; link "gensym.fn" as GS; fn alphaconvert(c, e) { switch (e) { - (E.amb_expr(expr1, expr2)) { + (M.amb_expr(expr1, expr2)) { // amb_expr(expr, expr) - E.amb_expr(alphaconvert(c, expr1), alphaconvert(c, expr2)) + M.amb_expr(alphaconvert(c, expr1), alphaconvert(c, expr2)) } - (E.apply(fun, args)) { + (M.apply(fun, args)) { // apply(expr, list(expr)) - E.apply(alphaconvert(c, fun), list.map(fn (arg) { alphaconvert(c, arg) }, args)) + M.apply(alphaconvert(c, fun), list.map(fn (arg) { alphaconvert(c, arg) }, args)) } - (x = E.back_expr) | - (x = E.env_expr) | - (x = E.error_expr) | - (x = E.bigint(_)) | - (x = E.character(_)) | - (x = E.constructor_info(_)) | - (x = E.stdint(_)) | - (x = E.constant(_)) { + (x = M.back_expr) | + (x = M.primop(_)) | + (x = M.env_expr) | + (x = M.error_expr) | + (x = M.bigint(_)) | + (x = M.character(_)) | + (x = M.constructor_info(_)) | + (x = M.stdint(_)) { x } - (E.callcc_expr(e)) { + (M.callcc_expr(e)) { // callcc_expr(expr) - E.callcc_expr(alphaconvert(c, e)) + M.callcc_expr(alphaconvert(c, e)) } - (E.cond_expr(test, branches)) { + (M.cond_expr(test, branches)) { // cond_expr(expr, list(#(expr, expr))) let #(vals, results) = list.unzip(branches); in - E.cond_expr(alphaconvert(c, test), + M.cond_expr(alphaconvert(c, test), list.zip(list.map(alphaconvert(c), vals), list.map(alphaconvert(c), results))) } - (E.construct(name, args)) { + (M.construct(name, args)) { // construct(string, list(expr)) - E.construct(name, list.map(alphaconvert(c), args)) + M.construct(name, list.map(alphaconvert(c), args)) } - (E.deconstruct(name, index, expr)) { + (M.deconstruct(name, index, expr)) { // deconstruct(string, number, expr) - E.deconstruct(name, index, alphaconvert(c, expr)) + M.deconstruct(name, index, alphaconvert(c, expr)) } - (E.if_expr(exprc, exprt, exprf)) { + (M.if_expr(exprc, exprt, exprf)) { // if_expr(expr, expr, expr) - E.if_expr(alphaconvert(c, exprc), - alphaconvert(c, exprt), - alphaconvert(c, exprf)) + M.if_expr(alphaconvert(c, exprc), + alphaconvert(c, exprt), + alphaconvert(c, exprf)) } - (E.lambda(params, body)) { + (M.lambda(params, body)) { // lambda(list(string), expr) let #(en, nsa) = c; newparams = list.map(GS.genstring, params); ee = Env.add_lists(Env.extend(en), params, newparams); in - E.lambda(newparams, alphaconvert(#(ee, nsa), body)) + M.lambda(newparams, alphaconvert(#(ee, nsa), body)) } - (E.letrec_expr(bindings, expr)) { + (M.letrec_expr(bindings, expr)) { // letrec_expr(list(#(string, expr)), expr) let #(en, nsa) = c; #(vars, exprs) = list.unzip(bindings); @@ -76,10 +76,10 @@ fn alphaconvert(c, e) { newvals = list.map(alphaconvert(#(ee, nsa)), exprs); // in new environment newbindings = list.zip(newvars, newvals); in - E.letrec_expr(newbindings, alphaconvert(#(ee, nsa), expr)) // new environment + M.letrec_expr(newbindings, alphaconvert(#(ee, nsa), expr)) // new environment } - (E.lookup(name, index, expr)) { + (M.lookup(name, index, expr)) { // lookup(string, number, expr) let #(e, nsa) = c; fn find { @@ -88,67 +88,62 @@ fn alphaconvert(c, e) { (_, []) { error("Namespace index out of bounds") } } in - E.lookup(name, index, alphaconvert(#(find(index, nsa), nsa), expr)) + M.lookup(name, index, alphaconvert(#(find(index, nsa), nsa), expr)) } - (E.make_tuple(args)) { + (M.make_tuple(args)) { // make_tuple(list(expr)) - E.make_tuple(list.map(alphaconvert(c), args)) + M.make_tuple(list.map(alphaconvert(c), args)) } - (E.make_vec(size, args)) { + (M.make_vec(size, args)) { // make_vec(number, list(expr)) - E.make_vec(size, list.map(alphaconvert(c), args)) + M.make_vec(size, list.map(alphaconvert(c), args)) } - (E.match_cases(test, cases)) { + (M.match_cases(test, cases)) { // match_cases(expr, list(#(list(number), expr))) let #(vals, results) = list.unzip(cases); in - E.match_cases(alphaconvert(c, test), - list.zip(vals, list.map(alphaconvert(c), results))) + M.match_cases(alphaconvert(c, test), + list.zip(vals, list.map(alphaconvert(c), results))) } - (E.namespaces(exprs)) { + (M.namespaces(exprs)) { // namespaces(list(expr)) - E.namespaces(list.map(alphaconvert(c), exprs)) + M.namespaces(list.map(alphaconvert(c), exprs)) } - (E.primapp(p, e1, e2)) { - // primapp(string, expr, expr) - E.primapp(p, alphaconvert(c, e1), alphaconvert(c, e2)) - } - - (E.print_exp(expr)) { + (M.print_exp(expr)) { // print_exp(expr) - E.print_exp(alphaconvert(c, expr)) + M.print_exp(alphaconvert(c, expr)) } - (E.sequence(exprs)) { + (M.sequence(exprs)) { // sequence(list(expr)) - E.sequence(list.map(alphaconvert(c), exprs)) + M.sequence(list.map(alphaconvert(c), exprs)) } - (E.tag(expr)) { + (M.tag(expr)) { // tag(expr) - E.tag(alphaconvert(c, expr)) + M.tag(alphaconvert(c, expr)) } - (E.tuple_index(size, index, expr)) { + (M.tuple_index(size, index, expr)) { // tuple_index(number, number, expr) - E.tuple_index(size, index, alphaconvert(c, expr)) + M.tuple_index(size, index, alphaconvert(c, expr)) } - (E.typedefs(defs, expr)) { + (M.typedefs(defs, expr)) { // typedefs(list(def), expr) - E.typedefs(defs, alphaconvert(c, expr)) + M.typedefs(defs, alphaconvert(c, expr)) } - (E.typeof_expr(expr)) { + (M.typeof_expr(expr)) { // typeof_expr(expr) - E.typeof_expr(alphaconvert(c, expr)) + M.typeof_expr(alphaconvert(c, expr)) } - (E.var(name)) { + (M.var(name)) { // var(string) let #(e, nsa) = c; v = Env.get(e, name); @@ -157,14 +152,14 @@ fn alphaconvert(c, e) { (nothing) { error("Unbound variable: " @@ name) } - (x=some(vname)) { - E.var(vname) + (x=just(vname)) { + M.var(vname) } } } (x) { - E.print_expr(x); + M.print_expr(x); puts("\n"); error("alphaconvert: unsupported expression") } diff --git a/fn/rewrite/beta_reduce.fn b/fn/rewrite/beta_reduce.fn index 1b003782..17597453 100644 --- a/fn/rewrite/beta_reduce.fn +++ b/fn/rewrite/beta_reduce.fn @@ -1,639 +1,132 @@ -let - link "expr.fn" as E; - link "env.fn" as Env; - link "subst.fn" as SUBST; - link "../listutils.fn" as list; - link "../ioutils.fn" as io; - import io operator "$_"; +namespace - fn genstring(p) { p @@ "$" @@ $incr() } - fn gensym(p) { E.var(genstring(p)) } +// β-reduction - fn subst (expr, var, arg) { // replace var with arg in expr - SUBST.substitute(DICT.make([var], [arg]), expr) - } - - fn betareduce(c, e) { - switch (e) { - (E.amb_expr(expr1, expr2)) { - // amb_expr(expr, expr) - E.amb_expr(betareduce(c, expr1), betareduce(c, expr2)) - } - - (E.apply(fun, args)) { - // apply(expr, list(expr)) - E.apply(betareduce(c, fun), list.map(fn (arg) { betareduce(c, arg) }, args)) - } - - (x = E.back_expr) | - (x = E.env_expr) | - (x = E.error_expr) | - (x = E.bigint(_)) | - (x = E.character(_)) | - (x = E.constructor_info(_)) | - (x = E.stdint(_)) | - (x = E.constant(_)) { - x - } - - (E.callcc_expr(e)) { - // callcc_expr(expr) - E.callcc_expr(betareduce(c, e)) - } - - (E.cond_expr(test, branches)) { - // cond_expr(expr, list(#(expr, expr))) - let #(vals, results) = list.unzip(branches); - in - E.cond_expr(betareduce(c, test), - list.zip(list.map(betareduce(c), vals), - list.map(betareduce(c), results))) - } - - (E.construct(name, args)) { - // construct(string, list(expr)) - E.construct(name, list.map(betareduce(c), args)) - } - - (E.deconstruct(name, index, expr)) { - // deconstruct(string, number, expr) - E.deconstruct(name, index, betareduce(c, expr)) - } - - (E.if_expr(exprc, exprt, exprf)) { - // if_expr(expr, expr, expr) - E.if_expr(betareduce(c, exprc), - betareduce(c, exprt), - betareduce(c, exprf)) - } - - (E.lambda(params, body)) { - // lambda(list(string), expr) - let #(en, nsa) = c; - newparams = list.map(genstring, params); - ee = Env.add_lists(Env.extend(en), params, newparams); - in - E.lambda(newparams, betareduce(#(ee, nsa), body)) - } - - (E.letrec_expr(bindings, expr)) { - // letrec_expr(list(#(string, expr)), expr) - let #(en, nsa) = c; - #(vars, exprs) = list.unzip(bindings); - newvars = list.map(genstring, vars); - ee = Env.add_lists(Env.extend(en), vars, newvars); - newvals = list.map(betareduce(#(ee, nsa)), exprs); // in new environment - newbindings = list.zip(newvars, newvals); - in - E.letrec_expr(newbindings, betareduce(#(ee, nsa), expr)) // new environment - } +link "minexpr.fn" as M; +link "env.fn" as Env; +link "subst.fn" as SUBST; +link "../listutils.fn" as list; +link "../dictutils.fn" as DICT; - (E.let_expr(bindings, expr)) { - // let_expr(list(#(string, expr)), expr) - let #(en, nsa) = c; - #(vars, exprs) = list.unzip(bindings); - newvals = list.map(betareduce(c), exprs); // in old environment - newvars = list.map(genstring, vars); - ee = Env.add_lists(Env.extend(en), vars, newvars); - newbindings = list.zip(newvars, newvals); - in - E.let_expr(newbindings, betareduce(#(ee, nsa), expr)) // new environment - } +fn reduce { + (M.amb_expr(expr1, expr2)) { + // amb_expr(expr, expr) + M.amb_expr(reduce(expr1), reduce(expr2)) + } - (E.letstar_expr(bindings, expr)) { - // letstar_expr(list(#(string, expr)), expr) - let - fn nest_lets { - ([], body) { body } - (#(var, exp) @ rest, body) { - E.let_expr([#(var, exp)], nest_lets(rest, body)) - } + (M.apply(fun, aargs)) { + // apply(expr, list(expr)) + let redaargs = list.map(reduce, aargs); + in + switch (fun) { + (M.lambda(fargs, body)) { + // handle currying + switch (list.length(fargs) <=> list.length(redaargs)) { + (lt) { + // ((λ (f1) body) a1 a2) => reduce(body[f1/a1] a2) + let newaargs = list.take(list.length(fargs), redaargs); + restaargs = list.drop(list.length(fargs), redaargs); + newbody = SUBST.substitute(DICT.make(fargs, newaargs), body); + in reduce(M.apply(reduce(newbody), restaargs)) } - in - betareduce(c, nest_lets(bindings, expr)); - } - - (E.lookup(name, index, expr)) { - // lookup(string, number, expr) - let #(e, nsa) = c; - fn find { - (0, h @ t) { h } - (n, h @ t) { find(n - 1, t) } - (_, []) { error("Namespace index out of bounds") } + (gt) { + // ((λ (f1 f2) body) a1) => (λ (f2) body[f1/a1]) + let newfargs = list.take(list.length(redaargs), fargs); + newbody = SUBST.substitute(DICT.make(newfargs, redaargs), body); + restfargs = list.drop(list.length(redaargs), fargs); + in M.lambda(restfargs, newbody); } - in - E.lookup(name, index, betareduce(#(find(index, nsa), nsa), expr)) - } - - (E.make_tuple(args)) { - // make_tuple(list(expr)) - E.make_tuple(list.map(betareduce(c), args)) - } - - (E.make_vec(size, args)) { - // make_vec(number, list(expr)) - E.make_vec(size, list.map(betareduce(c), args)) - } - - (E.match_cases(test, cases)) { - // match_cases(expr, list(#(list(number), expr))) - let #(vals, results) = list.unzip(cases); - in - E.match_cases(betareduce(c, test), - list.zip(vals, list.map(betareduce(c), results))) - } - - (E.namespaces(exprs)) { - // namespaces(list(expr)) - E.namespaces(list.map(betareduce(c), exprs)) - } - - (E.primapp(p, e1, e2)) { - // primapp(string, expr, expr) - E.primapp(p, betareduce(c, e1), betareduce(c, e2)) - } - - (E.print_exp(expr)) { - // print_exp(expr) - E.print_exp(betareduce(c, expr)) - } - - (E.sequence(exprs)) { - // sequence(list(expr)) - E.sequence(list.map(betareduce(c), exprs)) - } - - (E.tag(expr)) { - // tag(expr) - E.tag(betareduce(c, expr)) - } - - (E.tuple_index(size, index, expr)) { - // tuple_index(number, number, expr) - E.tuple_index(size, index, betareduce(c, expr)) - } - - (E.typedefs(defs, expr)) { - // typedefs(list(def), expr) - E.typedefs(defs, betareduce(c, expr)) - } - - (E.typeof_expr(expr)) { - // typeof_expr(expr) - E.typeof_expr(betareduce(c, expr)) - } - (E.var(name)) { - // var(string) - let #(e, nsa) = c; - v = Env.get(e, name); - in - switch (v) { - (nothing) { - error("Unbound variable: " @@ name) - } - (x=some(vname)) { - E.var(vname) - } + (eq) { + // ((λ (f1 f2) body) a1 a2) => reduce(body[f1/a1, f2/a2]) + let newbody = SUBST.substitute(DICT.make(fargs, redaargs), body); + in reduce(newbody) } + } } (x) { - E.print_expr(x); - puts("\n"); - error("betareduce: unsupported expression") + M.apply(reduce(x), redaargs) } } } -in - list.for_each(fn (str) { - let expr = E.parse(str); - in - E.print_expr(expr); - puts(" ==>\n "); - E.print_expr(betareduce(#(Env.root, []), expr)); - puts("\n\n") - }, - [ - // Basic application - "(let ((g 3) (a 4)) (g a))", - - // Simple lambda application - "(let ((h 1) (g 2)) ((lambda (x) (h x)) (g 4)))", - - // Lambda definition with primitives - "(lambda (a b) (+ a (* b 2)))", - - // Lambda application with primitives - nested - "((lambda (a b) (+ a (* b 2))) 3 4)", - - // Lambda application with function call in primitive - "(let ((f 5)) ((lambda (a b) (+ a (* (f b) 2))) 3 4))", - - // Amb operator (non-determinism) - "(amb 1 2)", - - // Simple call/cc - immediate escape - "(call/cc (lambda (k) (k 5)))", - - // call/cc that doesn't escape - "(call/cc (lambda (k) 42))", - - // call/cc with computation before escape - "(call/cc (lambda (k) (+ 10 (k 5))))", - - // Nested call/cc - "(call/cc (lambda (k1) (call/cc (lambda (k2) (k1 (k2 7))))))", - - // call/cc with amb - "(call/cc (lambda (k) (amb (k 1) (k 2))))", - - // Factorial with letrec - "(letrec ((fact (lambda (n) (if (== n 0) 1 (* n (fact (- n 1))))))) (fact 5))", - - // Multiple argument function - "((lambda (x y z) (+ x (+ y z))) 1 2 3)", - - // Nested lambdas (currying) - "((lambda (x) (lambda (y) (+ x y))) 5)", - // Application of curried function - "(((lambda (x) (lambda (y) (+ x y))) 5) 3)", - - // If expression with complex branches - "(let ((x 1) (f 2) (g 3)) (if (== x 0) (f 1) (g 2)))", - - // If with nested if - "(let ((x 1) (y 2)) (if (== x 0) (if (== y 0) 1 2) 3))", - - // Sequence (begin in Racket) - "(let ((f 1) (g 2) (h 3)) (begin (f 1) (g 2) (h 3)))", - - // Letrec with mutual recursion - "(letrec ((even (lambda (n) (if (= n 0) true (odd (- n 1))))) (odd (lambda (n) (if (= n 0) false (even (- n 1)))))) (even 5))", - - // Complex amb with computation - "(+ (amb 1 2) (amb 3 4))", - - // Nested application - "(let ((f 1) (g 2) (h 3) (x 4)) (f (g (h x))))", - - // Multiple primitives in sequence - "(+ (* 2 3) (- 5 1))", - - // call/cc capturing continuation in letrec - "(letrec ((k null)) (call/cc (lambda (cont) (begin (set! k cont) 42))))", - - // Lambda with no arguments - "((lambda () 42))", - - // call/cc with primitive operations - "(call/cc (lambda (k) (if (= 1 1) (k 10) 20)))", - - // Deeply nested primitives - "(+ 1 (+ 2 (+ 3 (+ 4 5))))", - - // Application with multiple complex arguments - "(let ((f 1) (g 2) (h 3) (i 4) (a 5) (b 6) (c 7)) (f (g a) (h b) (i c)))", - - // If where branches have applications - "(let ((test 1) (f 2) (g 3) (h 4) (i 5) (x 6) (y 7)) (if test (f (g x)) (h (i y))))", - - // Sequence with amb - "(begin (amb 1 2) (amb 3 4))", - - // call/cc that passes continuation to another function - "(let ((f 1)) (call/cc (lambda (k) (f k))))", - - // cond expression - like switch/case - "(let ((result1 1) (result2 2) (result3 3)) (let ((x 1)) (cond x (1 (result1)) (2 (result2)) (3 (result3)))))", - - // cond with complex test and results - "(let ((f 1) (x 2) (g 3) (h 4)) (cond (f x) (1 (g 1)) (2 (h 2))))", - - // construct with atomic arguments - "(construct pair 1 2)", - - // construct with complex arguments - "(let ((f 1) (g 2)) (construct pair (f 1) (g 2)))", - - // nested construct - "(let ((f 1) (g 2) (x 3) (y 4)) (construct cons (f x) (construct cons (g y) (constant nil))))", - - // deconstruct with atomic argument - "(let ((p 1)) (deconstruct pair 0 p))", - - // deconstruct with complex argument - "(let ((f 1) (x 2)) (deconstruct pair 1 (f x)))", - - // nested deconstruct - "(let ((f 1) (x 2)) (deconstruct pair 0 (deconstruct pair 1 (f x))))", - - // let with atomic value - "(let ((f 1)) (let ((x 42)) (f x)))", - - // let with complex value - "(let ((f 1) (g 2)) (let ((x (f 10))) (g x)))", - - // nested let - "(let ((f 1) (g 2) (h 3) (x 4)) (let ((x (f 1)) (y (g x))) (h x y)))", - - // nested let* - "(let ((f 1) (g 2) (h 3) (x 4)) (let* ((x (f 1)) (y (g x))) (h x y)))", - - // lookup with simple variable - // "(let ((ns 1) (x 2)) (lookup ns 0 x))", - - // lookup with function call - // "(lookup ns 0 (f x))", - - // nested lookup - // "(f (lookup ns 0 (g x)))", - - // make_tuple with atomic args - "(make_tuple 1 2 3)", - - // make_tuple with complex args - "(let ((f 1) (g 2)) (make_tuple (f 1) (g 2)))", - - // make_tuple with mixed args - "(let ((x 1) (y 2) (f 3)) (make_tuple x (f y) 42))", - - // make_vec with atomic args - "(make_vec 3 1 2 3)", - - // make_vec with complex args - "(let ((f 1) (g 2)) (make_vec 2 (f 1) (g 2)))", - - // make_vec with mixed args - "(let ((x 1) (y 2) (f 3)) (make_vec 3 x (f y) 42))", - - // match_cases with atomic test - "(let ((x 1) (r1 2) (r2 3)) (match_cases x ((1 2) (r1)) ((3 4 5) (r2))))", - - // match_cases with complex test - // "(match_cases (f x) ((1) (g 1)) ((2) (h 2)))", - - // match_cases with complex results - // "(match_cases x ((1) (f 1)) ((2) (g 2)))", - - // namespaces with atomic expressions - // "(namespaces x y z)", - - // namespaces with complex expressions - // "(namespaces (f 1) (g 2))", - - // namespaces with mixed expressions - // "(namespaces x (f y) z)", - - // namespaces with letrec bodies returning env - "(namespaces (letrec ((x 1) (y 2)) (let* ((f 1) (g f)) (env))) (letrec ((a 3) (b 4)) (env)))", - - // print_exp with atomic argument - "(let ((x 1)) (print x))", - - // print_exp with complex argument - "(let ((f 1) (x 2)) (print (f x)))", - - // print_exp nested in computation - "(let ((f 1) (x 2)) (+ (print (f x)) 10))", - - // tag with atomic argument - "(let ((x 1)) (tag x))", - - // tag with complex argument - "(let ((f 1) (x 2)) (tag (f x)))", + (x = M.back_expr) | + (x = M.primop(_)) | + (x = M.env_expr) | + (x = M.error_expr) | + (x = M.bigint(_)) | + (x = M.character(_)) | + (x = M.var(_)) | + (x = M.stdint(_)) { + x + } - // tag in cond test - "(let ((f 1) (x 2) (r1 3) (r2 4)) (cond (tag (f x)) (1 (r1)) (2 (r2))))", + (M.callcc_expr(e)) { + // callcc_expr(expr) + M.callcc_expr(reduce(e)) + } - // tuple_index with atomic tuple - "(let ((t 1)) (tuple_index 3 0 t))", + (M.cond_expr(test, branches)) { + // cond_expr(expr, list(#(expr, expr))) + let #(vals, results) = list.unzip(branches); + in + M.cond_expr(reduce(test), + list.zip(list.map(reduce, vals), + list.map(reduce, results))) + } - // tuple_index with complex tuple - "(let ((f 1) (x 2)) (tuple_index 2 1 (f x)))", + (M.if_expr(exprc, exprt, exprf)) { + // if_expr(expr, expr, expr) + M.if_expr(reduce(exprc), + reduce(exprt), + reduce(exprf)) + } - // nested tuple_index - "(let ((f 1) (x 2)) (tuple_index 2 0 (tuple_index 3 1 (f x))))", + (M.lambda(params, body)) { + // lambda(list(string), expr) + M.lambda(params, reduce(body)) + } - // typedefs with simple expression - "(let ((x 1)) (typedefs 0 x))", + (M.letrec_expr(bindings, expr)) { + // letrec_expr(list(#(string, expr)), expr) + let #(vars, exprs) = list.unzip(bindings); + newexprs = list.map(reduce, exprs); + newbindings = list.zip(vars, newexprs); + in + M.letrec_expr(newbindings, reduce(expr)) + } - // typedefs with letrec body - "(let ((g 1)) (typedefs 0 (letrec ((f (lambda (x) (g x)))) (f 42))))", + (M.lookup(name, index, expr)) { + // lookup(string, number, expr) + M.lookup(name, index, reduce(expr)) + } - // typedefs with complex body - "(let ((f 1) (g 2) (x 3)) (typedefs 0 (f (g x))))", + (M.make_vec(size, args)) { + // make_vec(number, list(expr)) + M.make_vec(size, list.map(reduce, args)) + } - // typedefs wrapping letrec with env body - "(typedefs 0 (letrec ((x 1) (y 2)) (env)))", + (M.match_cases(test, cases)) { + // match_cases(expr, list(#(list(number), expr))) + let #(vals, results) = list.unzip(cases); + in + M.match_cases(reduce(test), + list.zip(vals, list.map(reduce, results))) + } - // typeof_expr with atomic argument - "(let ((x 1)) (typeof x))", + (M.namespaces(exprs)) { + // namespaces(list(expr)) + M.namespaces(list.map(reduce, exprs)) + } - // typeof_expr with complex argument - "(let ((f 1) (x 2)) (typeof (f x)))", + (M.sequence(exprs)) { + // sequence(list(expr)) + M.sequence(list.map(reduce, exprs)) + } - // typeof_expr in conditional - "(let ((f 1) (x 2) (g 3) (h 4)) (if (typeof (f x)) (g 1) (h 2)))" - ]); -// -// output: -// -// (let [(g 3) (a 4)] (g a)) ==> -// (let [(g$1 3) (a$2 4)] (g$1 a$2)) -// -// (let [(h 1) (g 2)] ((λ (x) (h x)) (g 4))) ==> -// (let [(h$3 1) (g$4 2)] ((λ (x$5) (h$3 x$5)) (g$4 4))) -// -// (λ (a b) (+ a (* b 2))) ==> -// (λ (a$6 b$7) (+ a$6 (* b$7 2))) -// -// ((λ (a b) (+ a (* b 2))) 3 4) ==> -// ((λ (a$8 b$9) (+ a$8 (* b$9 2))) 3 4) -// -// (let [(f 5)] ((λ (a b) (+ a (* (f b) 2))) 3 4)) ==> -// (let [(f$10 5)] ((λ (a$11 b$12) (+ a$11 (* (f$10 b$12) 2))) 3 4)) -// -// (amb 1 2) ==> -// (amb 1 2) -// -// (call/cc (λ (k) (k 5))) ==> -// (call/cc (λ (k$13) (k$13 5))) -// -// (call/cc (λ (k) 42)) ==> -// (call/cc (λ (k$14) 42)) -// -// (call/cc (λ (k) (+ 10 (k 5)))) ==> -// (call/cc (λ (k$15) (+ 10 (k$15 5)))) -// -// (call/cc (λ (k1) (call/cc (λ (k2) (k1 (k2 7)))))) ==> -// (call/cc (λ (k1$16) (call/cc (λ (k2$17) (k1$16 (k2$17 7)))))) -// -// (call/cc (λ (k) (amb (k 1) (k 2)))) ==> -// (call/cc (λ (k$18) (amb (k$18 1) (k$18 2)))) -// -// (letrec [(fact (λ (n) (if (== n 0) 1 (* n (fact (- n 1))))))] (fact 5)) ==> -// (letrec [(fact$19 (λ (n$20) (if (== n$20 0) 1 (* n$20 (fact$19 (- n$20 1))))))] (fact$19 5)) -// -// ((λ (x y z) (+ x (+ y z))) 1 2 3) ==> -// ((λ (x$21 y$22 z$23) (+ x$21 (+ y$22 z$23))) 1 2 3) -// -// ((λ (x) (λ (y) (+ x y))) 5) ==> -// ((λ (x$24) (λ (y$25) (+ x$24 y$25))) 5) -// -// (((λ (x) (λ (y) (+ x y))) 5) 3) ==> -// (((λ (x$26) (λ (y$27) (+ x$26 y$27))) 5) 3) -// -// (let [(x 1) (f 2) (g 3)] (if (== x 0) (f 1) (g 2))) ==> -// (let [(x$28 1) (f$29 2) (g$30 3)] (if (== x$28 0) (f$29 1) (g$30 2))) -// -// (let [(x 1) (y 2)] (if (== x 0) (if (== y 0) 1 2) 3)) ==> -// (let [(x$31 1) (y$32 2)] (if (== x$31 0) (if (== y$32 0) 1 2) 3)) -// -// (let [(f 1) (g 2) (h 3)] (begin (f 1) (g 2) (h 3))) ==> -// (let [(f$33 1) (g$34 2) (h$35 3)] (begin (f$33 1) (g$34 2) (h$35 3))) -// -// (letrec [(even (λ (n) (if (= n 0) (constant true) (odd (- n 1))))) (odd (λ (n) (if (= n 0) (constant false) (even (- n 1)))))] (even 5)) ==> -// (letrec [(even$36 (λ (n$38) (if (= n$38 0) (constant true) (odd$37 (- n$38 1))))) (odd$37 (λ (n$39) (if (= n$39 0) (constant false) (even$36 (- n$39 1)))))] (even$36 5)) -// -// (+ (amb 1 2) (amb 3 4)) ==> -// (+ (amb 1 2) (amb 3 4)) -// -// (let [(f 1) (g 2) (h 3) (x 4)] (f (g (h x)))) ==> -// (let [(f$40 1) (g$41 2) (h$42 3) (x$43 4)] (f$40 (g$41 (h$42 x$43)))) -// -// (+ (* 2 3) (- 5 1)) ==> -// (+ (* 2 3) (- 5 1)) -// -// (letrec [(k (constant null))] (call/cc (λ (cont) (begin (set! k cont) 42)))) ==> -// (letrec [(k$44 (constant null))] (call/cc (λ (cont$45) (begin (set! k$44 cont$45) 42)))) -// -// ((λ () 42)) ==> -// ((λ () 42)) -// -// (call/cc (λ (k) (if (= 1 1) (k 10) 20))) ==> -// (call/cc (λ (k$46) (if (= 1 1) (k$46 10) 20))) -// -// (+ 1 (+ 2 (+ 3 (+ 4 5)))) ==> -// (+ 1 (+ 2 (+ 3 (+ 4 5)))) -// -// (let [(f 1) (g 2) (h 3) (i 4) (a 5) (b 6) (c 7)] (f (g a) (h b) (i c))) ==> -// (let [(f$47 1) (g$48 2) (h$49 3) (i$50 4) (a$51 5) (b$52 6) (c$53 7)] (f$47 (g$48 a$51) (h$49 b$52) (i$50 c$53))) -// -// (let [(test 1) (f 2) (g 3) (h 4) (i 5) (x 6) (y 7)] (if test (f (g x)) (h (i y)))) ==> -// (let [(test$54 1) (f$55 2) (g$56 3) (h$57 4) (i$58 5) (x$59 6) (y$60 7)] (if test$54 (f$55 (g$56 x$59)) (h$57 (i$58 y$60)))) -// -// (begin (amb 1 2) (amb 3 4)) ==> -// (begin (amb 1 2) (amb 3 4)) -// -// (let [(f 1)] (call/cc (λ (k) (f k)))) ==> -// (let [(f$61 1)] (call/cc (λ (k$62) (f$61 k$62)))) -// -// (let [(result1 1) (result2 2) (result3 3)] (let [(x 1)] (cond x (1 (result1)) (2 (result2)) (3 (result3))))) ==> -// (let [(result1$63 1) (result2$64 2) (result3$65 3)] (let [(x$66 1)] (cond x$66 (1 (result1$63)) (2 (result2$64)) (3 (result3$65))))) -// -// (let [(f 1) (x 2) (g 3) (h 4)] (cond (f x) (1 (g 1)) (2 (h 2)))) ==> -// (let [(f$67 1) (x$68 2) (g$69 3) (h$70 4)] (cond (f$67 x$68) (1 (g$69 1)) (2 (h$70 2)))) -// -// (construct pair 1 2) ==> -// (construct pair 1 2) -// -// (let [(f 1) (g 2)] (construct pair (f 1) (g 2))) ==> -// (let [(f$71 1) (g$72 2)] (construct pair (f$71 1) (g$72 2))) -// -// (let [(f 1) (g 2) (x 3) (y 4)] (construct cons (f x) (construct cons (g y) (constant nil)))) ==> -// (let [(f$73 1) (g$74 2) (x$75 3) (y$76 4)] (construct cons (f$73 x$75) (construct cons (g$74 y$76) (constant nil)))) -// -// (let [(p 1)] (deconstruct pair 0 p)) ==> -// (let [(p$77 1)] (deconstruct pair 0 p$77)) -// -// (let [(f 1) (x 2)] (deconstruct pair 1 (f x))) ==> -// (let [(f$78 1) (x$79 2)] (deconstruct pair 1 (f$78 x$79))) -// -// (let [(f 1) (x 2)] (deconstruct pair 0 (deconstruct pair 1 (f x)))) ==> -// (let [(f$80 1) (x$81 2)] (deconstruct pair 0 (deconstruct pair 1 (f$80 x$81)))) -// -// (let [(f 1)] (let [(x 42)] (f x))) ==> -// (let [(f$82 1)] (let [(x$83 42)] (f$82 x$83))) -// -// (let [(f 1) (g 2)] (let [(x (f 10))] (g x))) ==> -// (let [(f$84 1) (g$85 2)] (let [(x$86 (f$84 10))] (g$85 x$86))) -// -// (let [(f 1) (g 2) (h 3) (x 4)] (let [(x (f 1)) (y (g x))] (h x y))) ==> -// (let [(f$87 1) (g$88 2) (h$89 3) (x$90 4)] (let [(x$91 (f$87 1)) (y$92 (g$88 x$90))] (h$89 x$91 y$92))) -// -// (let [(f 1) (g 2) (h 3) (x 4)] (let* [(x (f 1)) (y (g x))] (h x y))) ==> -// (let [(f$93 1) (g$94 2) (h$95 3) (x$96 4)] (let [(x$97 (f$93 1))] (let [(y$98 (g$94 x$97))] (h$95 x$97 y$98)))) -// -// (make_tuple 1 2 3) ==> -// (make_tuple 1 2 3) -// -// (let [(f 1) (g 2)] (make_tuple (f 1) (g 2))) ==> -// (let [(f$99 1) (g$100 2)] (make_tuple (f$99 1) (g$100 2))) -// -// (let [(x 1) (y 2) (f 3)] (make_tuple x (f y) 42)) ==> -// (let [(x$101 1) (y$102 2) (f$103 3)] (make_tuple x$101 (f$103 y$102) 42)) -// -// (make_vec 3 1 2 3) ==> -// (make_vec 3 1 2 3) -// -// (let [(f 1) (g 2)] (make_vec 2 (f 1) (g 2))) ==> -// (let [(f$104 1) (g$105 2)] (make_vec 2 (f$104 1) (g$105 2))) -// -// (let [(x 1) (y 2) (f 3)] (make_vec 3 x (f y) 42)) ==> -// (let [(x$106 1) (y$107 2) (f$108 3)] (make_vec 3 x$106 (f$108 y$107) 42)) -// -// (let [(x 1) (r1 2) (r2 3)] (match_cases x ((1 2) (r1)) ((3 4 5) (r2)))) ==> -// (let [(x$109 1) (r1$110 2) (r2$111 3)] (match_cases x$109 ((1 2) (r1$110)) ((3 4 5) (r2$111)))) -// -// (namespaces (letrec [(x 1) (y 2)] (let* [(f 1) (g f)] (env))) (letrec [(a 3) (b 4)] (env))) ==> -// (namespaces (letrec [(x$112 1) (y$113 2)] (let [(f$114 1)] (let [(g$115 f$114)] (env)))) (letrec [(a$116 3) (b$117 4)] (env))) -// -// (let [(x 1)] (print x)) ==> -// (let [(x$118 1)] (print x$118)) -// -// (let [(f 1) (x 2)] (print (f x))) ==> -// (let [(f$119 1) (x$120 2)] (print (f$119 x$120))) -// -// (let [(f 1) (x 2)] (+ (print (f x)) 10)) ==> -// (let [(f$121 1) (x$122 2)] (+ (print (f$121 x$122)) 10)) -// -// (let [(x 1)] (tag x)) ==> -// (let [(x$123 1)] (tag x$123)) -// -// (let [(f 1) (x 2)] (tag (f x))) ==> -// (let [(f$124 1) (x$125 2)] (tag (f$124 x$125))) -// -// (let [(f 1) (x 2) (r1 3) (r2 4)] (cond (tag (f x)) (1 (r1)) (2 (r2)))) ==> -// (let [(f$126 1) (x$127 2) (r1$128 3) (r2$129 4)] (cond (tag (f$126 x$127)) (1 (r1$128)) (2 (r2$129)))) -// -// (let [(t 1)] (tuple_index 1 1 t)) ==> -// (let [(t$130 1)] (tuple_index 1 1 t$130)) -// -// (let [(f 1) (x 2)] (tuple_index 1 1 (f x))) ==> -// (let [(f$131 1) (x$132 2)] (tuple_index 1 1 (f$131 x$132))) -// -// (let [(f 1) (x 2)] (tuple_index 1 1 (tuple_index 1 1 (f x)))) ==> -// (let [(f$133 1) (x$134 2)] (tuple_index 1 1 (tuple_index 1 1 (f$133 x$134)))) -// -// (let [(x 1)] (typedefs 1 x)) ==> -// (let [(x$135 1)] (typedefs 1 x$135)) -// -// (let [(g 1)] (typedefs 1 (letrec [(f (λ (x) (g x)))] (f 42)))) ==> -// (let [(g$136 1)] (typedefs 1 (letrec [(f$137 (λ (x$138) (g$136 x$138)))] (f$137 42)))) -// -// (let [(f 1) (g 2) (x 3)] (typedefs 1 (f (g x)))) ==> -// (let [(f$139 1) (g$140 2) (x$141 3)] (typedefs 1 (f$139 (g$140 x$141)))) -// -// (typedefs 1 (letrec [(x 1) (y 2)] (env))) ==> -// (typedefs 1 (letrec [(x$142 1) (y$143 2)] (env))) -// -// (let [(x 1)] (typeof x)) ==> -// (let [(x$144 1)] (typeof x$144)) -// -// (let [(f 1) (x 2)] (typeof (f x))) ==> -// (let [(f$145 1) (x$146 2)] (typeof (f$145 x$146))) -// -// (let [(f 1) (x 2) (g 3) (h 4)] (if (typeof (f x)) (g 1) (h 2))) ==> -// (let [(f$147 1) (x$148 2) (g$149 3) (h$150 4)] (if (typeof (f$147 x$148)) (g$149 1) (h$150 2))) -// \ No newline at end of file + (x) { + M.print_expr(x); + puts("\n"); + error("reduce: unsupported expression") + } +} \ No newline at end of file diff --git a/fn/rewrite/closure-convert.fn b/fn/rewrite/closure-convert.fn index 236c3db6..9f30e018 100644 --- a/fn/rewrite/closure-convert.fn +++ b/fn/rewrite/closure-convert.fn @@ -1,26 +1,27 @@ namespace link "../listutils.fn" as list; link "../dictutils.fn" as DICT; -link "expr.fn" as E; +link "minexpr.fn" as M; link "transform.fn" as TR; link "freevars.fn" as FV; link "gensym.fn" as GS; link "subst.fn" as SUBST; fn closure_convert { - (exp=E.lambda(params, body)) { + (exp=M.lambda(params, body)) { let senv = GS.genstring("env"); sparams = senv @ params; fv = FV.free(exp); - venv = list.map(fn (v) { #(v, E.var(v)) }, fv); - sub = DICT.make(fv, list.map(fn (v) { E.env_ref(E.var(senv), v) }, fv)); + venv = list.map(fn (v) { #(v, M.var(v)) }, fv); + sub = DICT.make(fv, list.map(fn (v) { M.env_ref(M.var(senv), v) }, fv)); vbody = SUBST.substitute(sub, body); in - E.make_closure(E.lambdac(sparams, vbody), E.make_env(venv)) + M.make_closure(M.lambdac(sparams, vbody), M.make_env(venv)) } - (E.apply(func, args)) { - E.apply_closure(func, args) + (x=M.apply(M.primop(_), _)) { x } + (M.apply(func, args)) { + M.apply_closure(func, args) } (x) { x } } diff --git a/fn/rewrite/constant_folding.fn b/fn/rewrite/constant_folding.fn new file mode 100644 index 00000000..28250f4e --- /dev/null +++ b/fn/rewrite/constant_folding.fn @@ -0,0 +1,311 @@ +namespace + +// operator and constant folding + +link "minexpr.fn" as M; +link "../listutils.fn" as list; + +fn simplify (e) { + let + // a more convenient form for doing algebra + typedef term { + num(number) | + add(term, term) | + sub(term, term) | + mul(term, term) | + div(term, term) | + mod(term, term) | + pow(term, term) | + other(M.expr) + } + + // add and mul commute so either order should compare equal + EQ term { + (add(a, b), add(a, b)) | + (add(b, a), add(a, b)) | + (sub(a, b), sub(a, b)) | + (mul(a, b), mul(a, b)) | + (mul(b, a), mul(a, b)) | + (div(a, b), div(a, b)) | + (mod(a, b), mod(a, b)) | + (num(a), num(a)) | + (other(a), other(a)) { true } + (_, _) { false } + } + + fn e2t { + (M.bigint(n)) { num(n) } + (M.apply(M.primop("+"), [e1, e2])) { add(e2t(e1), e2t(e2)) } + (M.apply(M.primop("-"), [e1, e2])) { sub(e2t(e1), e2t(e2)) } + (M.apply(M.primop("*"), [e1, e2])) { mul(e2t(e1), e2t(e2)) } + (M.apply(M.primop("/"), [e1, e2])) { div(e2t(e1), e2t(e2)) } + (M.apply(M.primop("%"), [e1, e2])) { mod(e2t(e1), e2t(e2)) } + (M.apply(M.primop("**"), [e1, e2])) { pow(e2t(e1), e2t(e2)) } + (x) { other(x) } + } + + fn t2e { + (num(n)) { M.bigint(n) } + (add(a, b)) { M.apply(M.primop("+"), [t2e(a), t2e(b)]) } + (sub(a, b)) { M.apply(M.primop("-"), [t2e(a), t2e(b)]) } + (mul(a, b)) { M.apply(M.primop("*"), [t2e(a), t2e(b)]) } + (div(a, b)) { M.apply(M.primop("/"), [t2e(a), t2e(b)]) } + (mod(a, b)) { M.apply(M.primop("%"), [t2e(a), t2e(b)]) } + (pow(a, b)) { M.apply(M.primop("**"), [t2e(a), t2e(b)]) } + (other(x)) { x } + } + + fn prep { + (add(x, y)) { add(S(x), S(y)) } + (sub(x, y)) { sub(S(x), S(y)) } + (mul(x, y)) { mul(S(x), S(y)) } + (div(x, y)) { div(S(x), S(y)) } + (mod(x, y)) { mod(S(x), S(y)) } + (pow(x, y)) { pow(S(x), S(y)) } + (x) { x } + } + + fn S(term) { + switch(prep(term)) { + (add(num(a), num(b))) { num(a + b) } + (add(num(0), a)) | + (add(a, num(0))) { a } + (add(a, sub(num(0), a))) | + (add(sub(num(0), a), a)) { num(0) } + (add(num(a), add(num(b), x))) | + (add(num(a), add(x, num(b)))) | + (add(add(x, num(a)), num(b))) | + (add(add(num(a), x), num(b))) { S(add(num(a + b), x)) } + (add(num(a), sub(num(b), x))) | + (add(sub(num(b), x), num(a))) { S(sub(num(a + b), x)) } + (add(num(a), sub(x, num(b)))) | + (add(sub(x, num(b)), num(a))) { S(add(num(a - b), x)) } + (add(add(num(a), x), add(num(b), y))) | + (add(add(num(a), x), add(y, num(b)))) | + (add(add(x, num(a)), add(num(b), y))) | + (add(add(x, num(a)), add(y, num(b)))) { S(add(num(a + b), add(x, y))) } + (add(add(num(a), x), sub(num(b), y))) | + (add(sub(num(b), y), add(num(a), x))) | + (add(add(x, num(a)), sub(num(b), y))) | + (add(sub(num(b), y), add(x, num(a)))) { S(add(num(a + b), sub(x, y))) } + (add(add(num(a), x), sub(y, num(b)))) | + (add(sub(y, num(b)), add(num(a), x))) | + (add(add(x, num(a)), sub(y, num(b)))) | + (add(sub(y, num(b)), add(x, num(a)))) { S(add(num(a - b), add(x, y))) } + (add(sub(num(a), x), sub(num(b), y))) | + (add(sub(num(b), y), sub(num(a), x))) { S(sub(num(a + b), add(x, y))) } + (add(sub(x, num(a)), sub(num(b), y))) | + (add(sub(num(b), y), sub(x, num(a)))) { S(add(num(b - a), sub(x, y))) } + (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)) } + (sub(num(a), num(b))) { num(a - b) } + (sub(a, num(0))) { a } + (sub(x, x)) { num(0) } + (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))) | + (sub(add(x, num(a)), num(b))) { S(add(num(a - b), x)) } + (sub(sub(num(a), x), num(b))) { S(sub(num(a - b), x)) } + (sub(sub(x, num(a)), num(b))) { S(sub(x, num(a + b))) } + (sub(num(a), sub(num(b), x))) { S(add(num(a - b), x)) } + (sub(num(a), sub(x, num(b)))) { S(sub(num(a + b), x)) } + (sub(add(num(a), x), add(num(b), y))) | + (sub(add(x, num(a)), add(num(b), y))) | + (sub(add(num(a), x), add(y, num(b)))) | + (sub(add(x, num(a)), add(y, num(b)))) { S(add(num(a - b), sub(x, y))) } + (sub(sub(num(a), x), add(num(b), y))) | + (sub(sub(num(a), x), add(y, num(b)))) { S(sub(num(a - b), add(x, y))) } + (sub(sub(x, num(a)), add(num(b), y))) | + (sub(sub(x, num(a)), add(y, num(b)))) { S(sub(sub(x, num(a + b)), y)) } + (sub(add(x, num(a)), sub(num(b), y))) { S(add(num(a - b), add(x, y))) } + (sub(add(num(a), x), sub(y, num(b)))) | + (sub(add(x, num(a)), sub(y, num(b)))) { S(add(num(a + b), sub(x, y))) } + (sub(add(x, num(a)), sub(num(b), y))) | + (sub(add(x, num(a)), sub(y, num(b)))) { S(add(num(a - b), add(x, y))) } + (sub(add(num(a), x), sub(y, num(b)))) | + (sub(add(x, num(a)), sub(y, num(b)))) { S(add(num(a + b), sub(x, y))) } + (sub(sub(num(a), x), sub(num(b), y))) { S(sub(num(a - b), sub(x, y))) } + (sub(sub(x, num(a)), sub(num(b), y))) { S(add(sub(x, num(a + b)), y)) } + (sub(sub(x, num(a)), sub(y, num(b)))) { S(add(num(b - a), sub(x, y))) } + (sub(sub(num(a), x), sub(y, num(b)))) { S(sub(num(a + b), add(x, y))) } + (mul(num(a), num(b))) { num(a * b) } + (mul(num(0), a)) | + (mul(a, num(0))) { num(0) } + (mul(num(1), a)) | + (mul(a, num(1))) { a } + (mul(x, div(y, x))) | + (mul(div(y, x), x)) { y } + (mul(a, a)) { S(pow(a, num(2))) } + (mul(a, pow(a, b))) | + (mul(pow(a, b), a)) { S(pow(a, add(b, num(1)))) } + (mul(num(a), mul(num(b), x))) | + (mul(num(a), mul(x, num(b)))) | + (mul(mul(x, num(a)), num(b))) | + (mul(mul(num(a), x), num(b))) { S(mul(num(a * b), x)) } + (mul(num(a), add(x, num(b)))) | + (mul(num(a), add(num(b), x))) | + (mul(add(x, num(b)), num(a))) | + (mul(add(num(b), x), num(a))) { S(add(num(a * b), mul(num(a), x))) } + (mul(num(a), sub(x, num(b)))) | + (mul(sub(x, num(b)), num(a))) { S(sub(mul(num(a), x), num(a * b))) } + (mul(num(a), sub(num(b), x))) | + (mul(sub(num(b), x), num(a))) { S(sub(num(a * b), mul(num(a), x))) } + (mul(num(a), div(num(b), x))) | + (mul(div(num(b), x), num(a))) { S(div(num(a * b), x)) } + (mul(num(a), div(x, num(b)))) | + (mul(div(x, num(b)), num(a))) { S(mul(num(a / b), x)) } + (mul(pow(x, a), pow(x, b))) { S(pow(x, add(a, b))) } + (mul(a, a)) { S(pow(a, num(2))) } + (div(num(a), num(b))) { num(a / b) } + (div(a, num(1))) { a } + (div(num(0), _)) { num(0) } + (div(x, x)) { num(1) } + (div(div(x, num(a)), num(b))) { S(div(x, num(a * b))) } + (div(div(num(a), x), num(b))) { S(div(num(a / b), x)) } + (div(num(a), div(num(b), x))) { S(mul(num(a / b), x)) } + (div(num(a), div(x, num(b)))) { S(div(num(a * b), x)) } + (div(num(a), mul(x, num(b)))) | + (div(num(a), mul(num(b), x))) { S(div(num(a / b), x)) } + (div(mul(num(a), x), num(b))) | + (div(mul(x, num(a)), num(b))) { S(mul(num(a / b), x)) } + (div(add(num(a), x), num(b))) | + (div(add(x, num(a)), num(b))) { S(add(num(a / b), div(x, num(b)))) } + (div(sub(num(a), x), num(b))) { S(sub(num(a / b), div(x, num(b)))) } + (div(sub(x, num(a)), num(b))) { S(sub(div(x, num(b)), num(a / b))) } + (mul(div(x, num(a)), div(y, num(b)))) { S(div(mul(x, y), num(a * b))) } + (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))) } + (mod(num(a), num(b))) { num(a % b) } + (mod(num(0), _)) { num(0) } + (mod(_, num(1))) { num(0) } + (mod(x, x)) { num(0) } + (mod(mod(a, x), x)) { mod(a, x) } + (pow(num(a), num(b))) { num(a ** b) } + (pow(_, num(0))) { num(1) } + (pow(x, num(1))) { x } + (pow(num(0), _)) { num(0) } + (pow(num(1), _)) { num(1) } + (pow(pow(x, a), b)) { S(pow(x, mul(a, b))) } + (x) { x } + }; + } + in + t2e(S(e2t(e))) +} + +fn fold { + (M.amb_expr(expr1, expr2)) { + // amb_expr(expr, expr) + M.amb_expr(fold(expr1), fold(expr2)) + } + + (x = M.apply(fun, args)) { + // apply(expr, list(expr)) + { + let f = fold(fun); + a = list.map(fold, args); + in + switch (f) { + (M.primop(_)) { + simplify(M.apply(f, a)) + } + (_) { + M.apply(f, a) + } + } + } + } + + (x = M.back_expr) | + (x = M.primop(_)) | + (x = M.env_expr) | + (x = M.error_expr) | + (x = M.bigint(_)) | + (x = M.character(_)) | + (x = M.var(_)) | + (x = M.stdint(_)) { + x + } + + (M.callcc_expr(e)) { + // callcc_expr(expr) + M.callcc_expr(fold(e)) + } + + (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.if_expr(exprc, exprt, exprf)) { + // if_expr(expr, expr, expr) + let exprc = fold(exprc); + in + switch (exprc) { + (M.bigint(n)) { + if (n != 0) { + fold(exprt) + } else { + fold(exprf) + } + } + (_) { + M.if_expr(exprc, fold(exprt), fold(exprf)) + } + } + } + + (M.lambda(params, body)) { + // lambda(list(string), expr) + M.lambda(params, fold(body)) + } + + (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.lookup(name, index, expr)) { + // lookup(string, number, expr) + M.lookup(name, index, fold(expr)) + } + + (M.make_vec(size, args)) { + // make_vec(number, list(expr)) + M.make_vec(size, list.map(fold, args)) + } + + (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.namespaces(exprs)) { + // namespaces(list(expr)) + M.namespaces(list.map(fold, exprs)) + } + + (M.sequence(exprs)) { + // sequence(list(expr)) + M.sequence(list.map(fold, exprs)) + } + + (x) { + M.print_expr(x); + puts("\n"); + error("fold: unsupported expression") + } +} \ No newline at end of file diff --git a/fn/rewrite/cps.fn b/fn/rewrite/cps.fn index 903db51d..73ee0660 100644 --- a/fn/rewrite/cps.fn +++ b/fn/rewrite/cps.fn @@ -1,33 +1,32 @@ namespace - link "expr.fn" as E; + link "minexpr.fn" as M; link "../listutils.fn" as list; link "gensym.fn" as GS; fn isAexpr { - (E.var(_)) | - (E.back_expr) | - (E.character(_)) | - (E.constant(_)) | - (E.constructor_info(_)) | - (E.env_expr) | - (E.error_expr) | - (E.lambda(_, _)) | - (E.stdint(_)) | - (E.bigint(_)) { true } + (M.var(_)) | + (M.primop(_)) | + (M.back_expr) | + (M.character(_)) | + (M.env_expr) | + (M.error_expr) | + (M.lambda(_, _)) | + (M.stdint(_)) | + (M.bigint(_)) { true } (_) { false } } fn M { - (E.lambda(vars, body)) { + (M.lambda(vars, body)) { let c = GS.genstring("$k"); - in E.lambda(vars @@ [c], T_c(body, E.var(c))) + in M.lambda(vars @@ [c], T_c(body, M.var(c))) } (x) { x } } fn kToC(k) { let rv = GS.genstring("$rv"); - in E.lambda([rv], k(E.var(rv))) + in M.lambda([rv], k(M.var(rv))) } fn T_k(e, k) { @@ -35,144 +34,90 @@ namespace k(M(e)) } else { switch (e) { - (E.amb_expr(expr1, expr2)) { + (M.amb_expr(expr1, expr2)) { let c = kToC(k); in - E.amb_expr(T_c(expr1, c), T_c(expr2, c)) + M.amb_expr(T_c(expr1, c), T_c(expr2, c)) } - (E.apply(_, _)) { + (M.apply(_, _)) { let c = kToC(k); in T_c(e, c) } - (E.callcc_expr(e)) { + (M.callcc_expr(e)) { let c = kToC(k); in - T_c(E.callcc_expr(e), c) + T_c(M.callcc_expr(e), c) } - (E.cond_expr(test, branches)) { + (M.cond_expr(test, branches)) { let c = kToC(k); in T_k(test, fn (atest) { - E.cond_expr(atest, list.map(fn {(#(val, result)) { + M.cond_expr(atest, list.map(fn {(#(val, result)) { #(val, T_c(result, c)) }}, branches)) }) } - (E.construct(name, args)) { - Ts_k(args, fn (sargs) { - k(E.construct(name, sargs)) - }) - } - - (E.deconstruct(name, index, expr)) { - T_k(expr, fn (sexpr) { - k(E.deconstruct(name, index, sexpr)) - }) - } - - (E.if_expr(exprc, exprt, exprf)) { + (M.if_expr(exprc, exprt, exprf)) { let c = kToC(k); in T_k(exprc, fn(aexp) { - E.if_expr(aexp, T_c(exprt, c), T_c(exprf, c)) + M.if_expr(aexp, T_c(exprt, c), T_c(exprf, c)) }) } - (E.letrec_expr(bindings, expr)) { + (M.letrec_expr(bindings, expr)) { let #(vars, aexps) = list.unzip(bindings); in - E.letrec_expr(list.zip(vars, list.map(M, aexps)), T_k(expr, k)) + M.letrec_expr(list.zip(vars, list.map(M, aexps)), T_k(expr, k)) } - (E.lookup(name, index, expr)) { - E.lookup(name, index, T_k(expr, k)) + (M.lookup(name, index, expr)) { + M.lookup(name, index, T_k(expr, k)) } - (E.make_tuple(args)) { + (M.make_vec(size, args)) { Ts_k(args, fn (sargs) { - k(E.make_tuple(sargs)) + k(M.make_vec(size, sargs)) }) } - (E.make_vec(size, args)) { - Ts_k(args, fn (sargs) { - k(E.make_vec(size, sargs)) - }) - } - - (E.match_cases(test, cases)) { + (M.match_cases(test, cases)) { let c = kToC(k); in T_k(test, fn (atest) { - E.match_cases(atest, list.map(fn {(#(indices, result)) { + M.match_cases(atest, list.map(fn {(#(indices, result)) { #(indices, T_c(result, c)) }}, cases)) }) } - (E.namespaces(exprs)) { + (M.namespaces(exprs)) { Ts_k(exprs, fn (sexprs) { - k(E.namespaces(sexprs)) - }) - } - - (E.primapp(p, e1, e2)) { - T_k(e1, fn (s1) { - T_k(e2, fn (s2) { - k(E.primapp(p, s1, s2)) - }) + k(M.namespaces(sexprs)) }) } - (E.print_exp(expr)) { - T_k(expr, fn (sexpr) { - k(E.print_exp(sexpr)) - }) - } - - (E.sequence([expr])) { T_k(expr, k) } - (E.sequence(expr @ exprs)) { + (M.sequence([expr])) { T_k(expr, k) } + (M.sequence(expr @ exprs)) { T_k(expr, fn (ignored) { - T_k(E.sequence(exprs), k) - }) - } - - (E.tag(expr)) { - T_k(expr, fn (sexpr) { - k(E.tag(sexpr)) - }) - } - - (E.tuple_index(size, index, expr)) { - T_k(expr, fn (sexpr) { - k(E.tuple_index(size, index, sexpr)) - }) - } - - (E.typedefs(defs, expr)) { - E.typedefs(defs, T_k(expr, k)) - } - - (E.typeof_expr(expr)) { - T_k(expr, fn (sexpr) { - k(E.typeof_expr(sexpr)) + T_k(M.sequence(exprs), k) }) } (x) { - E.print_expr(x); + M.print_expr(x); puts("\n"); error("T_k: unsupported expression") } @@ -182,152 +127,106 @@ namespace fn T_c(expr, c) { if (isAexpr(expr)) { - E.apply(c, [M(expr)]) + M.apply(c, [M(expr)]) } else { switch(expr) { - (E.amb_expr(expr1, expr2)) { + (M.amb_expr(expr1, expr2)) { let sk = GS.genstring("$k"); - vsk = E.var(sk); + vsk = M.var(sk); in - E.apply(E.lambda([sk], E.amb_expr(T_c(expr1, vsk), T_c(expr2, vsk))), [c]) + M.apply(M.lambda([sk], M.amb_expr(T_c(expr1, vsk), T_c(expr2, vsk))), [c]) + } + + (M.apply(p=M.primop(_), [e1, e2])) { + T_k(e1, fn (s1) { + T_k(e2, fn (s2) { + M.apply(c, [M.apply(p, [s1, s2])]) + }) + }) } - (E.apply(f, es)) { + (M.apply(f, es)) { T_k(f, fn(sf) { - Ts_k(es, fn (ses) {E.apply(sf, ses @@ [c])}) + Ts_k(es, fn (ses) {M.apply(sf, ses @@ [c])}) }) } - (E.callcc_expr(e)) { + (M.callcc_expr(e)) { T_k(e, fn (sf) { - E.apply( - E.parse("(lambda (f cc) (f (lambda (x i) (cc x)) cc))"), + M.apply( + M.parse("(λ (f cc) (f (λ (x i) (cc x)) cc))"), [sf, c] ) }) } - (E.cond_expr(test, branches)) { + (M.cond_expr(test, branches)) { let sk = GS.genstring("$k"); - vsk = E.var(sk); + vsk = M.var(sk); in - E.apply(E.lambda([sk], T_k(test, fn (atest) { - E.cond_expr(atest, list.map(fn {(#(val, result)) { + M.apply(M.lambda([sk], T_k(test, fn (atest) { + M.cond_expr(atest, list.map(fn {(#(val, result)) { #(val, T_c(result, vsk)) }}, branches)) })), [c]) } - (E.construct(name, args)) { - Ts_k(args, fn (sargs) { - E.apply(c, [E.construct(name, sargs)]) - }) - } - - (E.deconstruct(name, index, expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.deconstruct(name, index, sexpr)]) - }) - } - - (E.if_expr(exprc, exprt, exprf)) { + (M.if_expr(exprc, exprt, exprf)) { let sk = GS.genstring("$k"); - vsk = E.var(sk); + vsk = M.var(sk); in - E.apply(E.lambda([sk], T_k(exprc, fn (aexp) { - E.if_expr(aexp, T_c(exprt,vsk), T_c(exprf,vsk)) + M.apply(M.lambda([sk], T_k(exprc, fn (aexp) { + M.if_expr(aexp, T_c(exprt,vsk), T_c(exprf,vsk)) })), [c]) } - (E.letrec_expr(bindings, expr)) { + (M.letrec_expr(bindings, expr)) { let #(vars, aexps) = list.unzip(bindings); in - E.letrec_expr(list.zip(vars, list.map(M, aexps)), T_c(expr, c)) - } - - (E.lookup(name, index, expr)) { - E.lookup(name, index, T_c(expr, c)) + M.letrec_expr(list.zip(vars, list.map(M, aexps)), T_c(expr, c)) } - (E.make_tuple(args)) { - Ts_k(args, fn (sargs) { - E.apply(c, [E.make_tuple(sargs)]) - }) + (M.lookup(name, index, expr)) { + M.lookup(name, index, T_c(expr, c)) } - (E.make_vec(size, args)) { + (M.make_vec(size, args)) { Ts_k(args, fn (sargs) { - E.apply(c, [E.make_vec(size, sargs)]) + M.apply(c, [M.make_vec(size, sargs)]) }) } - (E.match_cases(test, cases)) { + (M.match_cases(test, cases)) { let sk = GS.genstring("$k"); - vsk = E.var(sk); + vsk = M.var(sk); in - E.apply(E.lambda([sk], T_k(test, fn (atest) { - E.match_cases(atest, list.map(fn {(#(indices, result)) { + M.apply(M.lambda([sk], T_k(test, fn (atest) { + M.match_cases(atest, list.map(fn {(#(indices, result)) { #(indices, T_c(result, vsk)) }}, cases)) })), [c]) } - (E.namespaces(exprs)) { + (M.namespaces(exprs)) { Ts_k(exprs, fn (sexprs) { - E.apply(c, [E.namespaces(sexprs)]) - }) - } - - (E.primapp(p, e1, e2)) { - T_k(e1, fn (s1) { - T_k(e2, fn (s2) { - E.apply(c, [E.primapp(p, s1, s2)]) - }) + M.apply(c, [M.namespaces(sexprs)]) }) } - (E.print_exp(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.print_exp(sexpr)]) - }) - } - - (E.sequence([expr])) { T_c(expr, c) } - (E.sequence(expr @ exprs)) { + (M.sequence([expr])) { T_c(expr, c) } + (M.sequence(expr @ exprs)) { T_k(expr, fn (ignored) { - T_c(E.sequence(exprs), c) - }) - } - - (E.tag(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.tag(sexpr)]) - }) - } - - (E.tuple_index(size, index, expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.tuple_index(size, index, sexpr)]) - }) - } - - (E.typedefs(defs, expr)) { - E.typedefs(defs, T_c(expr, c)) - } - - (E.typeof_expr(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.typeof_expr(sexpr)]) + T_c(M.sequence(exprs), c) }) } (x) { - E.print_expr(x); + M.print_expr(x); puts("\n"); error("T_c: unsupported expression") } diff --git a/fn/rewrite/curry.fn b/fn/rewrite/curry.fn new file mode 100644 index 00000000..0040a387 --- /dev/null +++ b/fn/rewrite/curry.fn @@ -0,0 +1,78 @@ +namespace + +link "../listutils.fn" as list; +link "minexpr.fn" as M; +import list operator "_|>_"; +import list operator "_&&_"; + +fn curry { + (M.amb_expr(e1, e2)) { + M.amb_expr(curry(e1), curry(e2)) + } + + (M.apply(x=M.primop(_), args)) { + M.apply(x, args |> curry) + } + + (M.apply(e, [])) { + M.apply(curry(e), []) + } + + (M.apply(e, [a])) { + M.apply(curry(e), [curry(a)]) + } + + (M.apply(e, a @ rest)) { + curry(M.apply(M.apply(e, [curry(a)]), rest)) + } + + (M.callcc_expr(e)) { + M.callcc_expr(curry(e)) + } + + (M.cond_expr(e, cases)) { + M.cond_expr(curry(e), cases |> identity && curry) + } + + (M.if_expr(e1, e2, e3)) { + M.if_expr(curry(e1), curry(e2), curry(e3)) + } + + (M.lambda([], body)) { + M.lambda([], curry(body)) + } + + (M.lambda([a], body)) { + M.lambda([a], curry(body)) + } + + (M.lambda(a @ rest, body)) { + M.lambda([a], curry(M.lambda(rest, body))) + } + + (M.letrec_expr(bindings, body)) { + M.letrec_expr(bindings |> identity && curry, curry(body)) + } + + (M.lookup(name, id, e)) { + M.lookup(name, id, curry(e)) + } + + (M.make_vec(num, exprs)) { + M.make_vec(num, exprs |> curry) + } + + (M.match_cases(e, cases)) { + M.match_cases(curry(e), cases |> identity && curry) + } + + (M.namespaces(exprs)) { + M.namespaces(exprs |> curry) + } + + (M.sequence(exprs)) { + M.sequence(exprs |> curry) + } + + (x) { x } +} \ No newline at end of file diff --git a/fn/rewrite/desugar.fn b/fn/rewrite/desugar.fn index 8e4e1ef0..8ce858a3 100644 --- a/fn/rewrite/desugar.fn +++ b/fn/rewrite/desugar.fn @@ -1,5 +1,6 @@ namespace link "expr.fn" as E; + link "minexpr.fn" as M; link "../listutils.fn" as list; link "../dictutils.fn" as DICT; link "../ioutils.fn" as IO; @@ -16,23 +17,18 @@ namespace fn ds { (E.amb_expr(expr1, expr2)) { // amb_expr(expr, expr) - E.amb_expr(ds(expr1), ds(expr2)) - } - - // apply_closure(expr, list(expr)) - (E.apply_closure(f, args)) { - E.apply_closure(ds(f), list.map(ds, args)) + M.amb_expr(ds(expr1), ds(expr2)) } (E.apply(E.var(v), args)) { switch (DICT.lookup(v, c)) { (nothing) { - E.apply(E.var(v), list.map(ds, args)) + M.apply(M.var(v), list.map(ds, args)) } - (some(arity)) { + (just(arity)) { switch (list.length(args) <=> arity) { (eq) { - E.apply(E.var(v), list.map(ds, args)) + M.apply(M.var(v), list.map(ds, args)) } (lt) { // (add 2) -> (lambda (arg0) (add 2 arg0)) @@ -40,10 +36,10 @@ namespace missing = arity - list.length(args); new_params = list.map(fn (i) { "arg$" @@ $i }, list.range(0, missing)); - new_args = list.map(fn (v) { E.var(v) }, new_params) @@ list.map(ds, args); + new_args = list.map(fn (v) { M.var(v) }, new_params) @@ list.map(ds, args); in - E.lambda(new_params, - E.apply(E.var(v), new_args)) + M.lambda(new_params, + M.apply(M.var(v), new_args)) ; } (gt) { @@ -51,8 +47,8 @@ namespace let first_args = list.take(arity, args); remaining_args = list.drop(arity, args); in - E.apply( - E.apply(E.var(v), list.map(ds, first_args)), + M.apply( + M.apply(M.var(v), list.map(ds, first_args)), list.map(ds, remaining_args) ) } @@ -63,72 +59,54 @@ namespace (E.apply(fun, args)) { // apply(expr, list(expr)) - E.apply(ds(fun), list.map(ds, args)) + M.apply(ds(fun), list.map(ds, args)) } - (x = E.back_expr) | - (x = E.env_expr) | - (x = E.error_expr) | - (x = E.bigint(_)) | - (x = E.character(_)) | - (x = E.constructor_info(_)) | - (x = E.stdint(_)) | - (x = E.var(_)) | - (x = E.constant(_)) { x } + (E.back_expr) { M.back_expr } + (E.env_expr) { M.env_expr } + (E.error_expr) { M.error_expr } + (E.bigint(i)) { M.bigint(i) } + (E.character(c)) { M.character(c) } + (E.constructor_info(_)) { error("desugar: constructor_info not supported") } + (E.stdint(i)) { M.stdint(i) } + (E.var(v)) { M.var(v) } + (E.constant(name, n)) { M.stdint(n) } (E.callcc_expr(e)) { // callcc_expr(expr) - E.callcc_expr(ds(e)) + M.callcc_expr(ds(e)) } (E.cond_expr(test, branches)) { // cond_expr(expr, list(#(expr, expr))) let #(vals, results) = list.unzip(branches); - in E.cond_expr(ds(test), + in M.cond_expr(ds(test), list.zip(list.map(ds, vals), list.map(ds, results))) } - (E.construct(name, args)) { + (E.construct(name, tag, args)) { // construct(string, list(expr)) - E.construct(name, list.map(ds, args)) + let aargs = E.stdint(tag) @ args + in + ds(E.make_vec(list.length(aargs), aargs)) } (E.deconstruct(name, index, expr)) { // deconstruct(string, number, expr) - E.deconstruct(name, index, ds(expr)) + M.apply(M.primop("vec-ref"), [M.stdint(index), ds(expr)]) } (E.if_expr(exprc, exprt, exprf)) { // if_expr(expr, expr, expr) - E.if_expr(ds(exprc), + M.if_expr(ds(exprc), ds(exprt), ds(exprf)) } (E.lambda(params, body)) { // lambda(list(string), expr) - E.lambda(params, ds(body)) - } - - (E.lambdac(params, body)) { - // lambda(list(string), expr) - E.lambdac(params, ds(body)) - } - - (E.make_closure(body, env)) { - // make_closure(expr, env) - E.make_closure(ds(body), ds(env)) - } - - // make_env(list(#(string, expr))) - (E.make_env(bindings)) { - E.make_env(list.map(fn (#(v, e)) { #(v, ds(e)) }, bindings)) - } - - // env_ref(expr, string) - (E.env_ref(e, s)) { - E.env_ref(ds(e), s) + M.lambda(params, ds(body)) } (E.letrec_expr(bindings, expr)) { @@ -136,13 +114,12 @@ namespace let c2 = list.foldl(fn (#(v, e), dict) { switch (e) { - (E.lambda(params, _)) | - (E.lambdac(params, _)) { DICT.insert(v, list.length(params), dict) } + (E.lambda(params, _)) { DICT.insert(v, list.length(params), dict) } (_) { dict } } }, c, bindings); bindings2 = list.map(fn (#(v, e)) { #(v, desug(e, c2)) }, bindings); - in E.letrec_expr(bindings2, desug(expr, c2)) // new environment + in M.letrec_expr(bindings2, desug(expr, c2)) // new environment } (E.let_expr(bindings, expr)) { @@ -150,15 +127,14 @@ namespace let c2 = list.foldl(fn (#(v, e), dict) { switch (e) { - (E.lambda(params, _)) | - (E.lambdac(params, _)) { DICT.insert(v, list.length(params), dict) } + (E.lambda(params, _)) { DICT.insert(v, list.length(params), dict) } (_) { dict } } }, c, bindings); // let expressions are evaluated in the containing environment c bindings2 = list.map(fn (#(v, e)) { #(v, desug(e, c)) }, bindings); #(vars, vals) = list.unzip(bindings2); - in E.apply(E.lambda(vars, desug(expr, c2)), vals) + in M.apply(M.lambda(vars, desug(expr, c2)), vals) } (E.letstar_expr(bindings, expr)) { @@ -175,65 +151,65 @@ namespace (E.lookup(name, index, expr)) { // lookup(string, number, expr) - E.lookup(name, index, ds(expr)) + M.lookup(name, index, ds(expr)) } (E.make_tuple(args)) { // make_tuple(list(expr)) - E.make_tuple(list.map(ds, args)) + M.make_vec(list.length(args), list.map(ds, args)) } (E.make_vec(size, args)) { // make_vec(number, list(expr)) - E.make_vec(size, list.map(ds, args)) + M.make_vec(size, list.map(ds, args)) } (E.match_cases(test, cases)) { // match_cases(expr, list(#(list(number), expr))) let #(vals, results) = list.unzip(cases); in - E.match_cases(ds(test), + M.match_cases(ds(test), list.zip(vals, list.map(ds, results))) } (E.namespaces(exprs)) { // namespaces(list(expr)) - E.namespaces(list.map(ds, exprs)) + M.namespaces(list.map(ds, exprs)) } (E.primapp(p, e1, e2)) { // primapp(string, expr, expr) - E.primapp(p, ds(e1), ds(e2)) + M.apply(M.primop(p), [ds(e1), ds(e2)]) } (E.print_exp(expr)) { // print_exp(expr) - E.print_exp(ds(expr)) + M.apply(M.lambda(["x"], M.var("x")), [ds(expr)]) } (E.sequence(exprs)) { // sequence(list(expr)) - E.sequence(list.map(ds, exprs)) + M.sequence(list.map(ds, exprs)) } (E.tag(expr)) { // tag(expr) - E.tag(ds(expr)) + ds(E.primapp("vec", E.stdint(0), expr)) } (E.tuple_index(size, index, expr)) { // tuple_index(number, number, expr) - E.tuple_index(size, index, ds(expr)) + ds(E.primapp("vec", E.stdint(index), expr)) } (E.typedefs(defs, expr)) { // typedefs(list(def), expr) - E.typedefs(defs, ds(expr)) + ds(expr) } (E.typeof_expr(expr)) { - // typeof_expr(expr) - E.typeof_expr(ds(expr)) + // typeof_expr(expr) -> string + M.make_vec(2, [M.character('t'), M.make_vec(0, [])]) } (x) { diff --git a/fn/rewrite/env.fn b/fn/rewrite/env.fn index 49782ef9..6e16e686 100644 --- a/fn/rewrite/env.fn +++ b/fn/rewrite/env.fn @@ -35,7 +35,7 @@ namespace (env(dict, parent), k) { switch (D.lookup(k, dict)) { (nothing) { get(parent, k) } - (x=some(_)) { x } + (x=just(_)) { x } } } } \ No newline at end of file diff --git a/fn/rewrite/eta_reduce.fn b/fn/rewrite/eta_reduce.fn new file mode 100644 index 00000000..a0d87f13 --- /dev/null +++ b/fn/rewrite/eta_reduce.fn @@ -0,0 +1,220 @@ +namespace + +// η-reduction + +link "minexpr.fn" as M; +link "env.fn" as Env; +link "subst.fn" as SUBST; +link "../listutils.fn" as list; +link "../dictutils.fn" as DICT; + +fn subst (expr, var, arg) { // replace var with arg in expr + SUBST.substitute(DICT.make([var], [arg]), expr) +} + +fn occurs_in (var, expr) { + switch (expr) { + (M.amb_expr(expr1, expr2)) { + // amb_expr(expr, expr) + occurs_in(var, expr1) or occurs_in(var, expr2) + } + + (M.apply(fun, args)) { + // apply(expr, list(expr)) + occurs_in(var, fun) or list.any(occurs_in(var), args) + } + + (M.var(_)) { + // var(string) + var == expr + } + + (x = M.back_expr) | + (x = M.primop(_)) | + (x = M.env_expr) | + (x = M.error_expr) | + (x = M.bigint(_)) | + (x = M.character(_)) | + (x = M.stdint(_)) { + false + } + + (M.callcc_expr(e)) { + // callcc_expr(expr) + occurs_in(var, e) + } + + (M.cond_expr(test, branches)) { + // cond_expr(expr, list(#(expr, expr))) + let #(vals, results) = list.unzip(branches); + in + occurs_in(var, test) or list.any(occurs_in(var), vals) or list.any(occurs_in(var), results) + } + + (M.if_expr(exprc, exprt, exprf)) { + // if_expr(expr, expr, expr) + occurs_in(var, exprc) or occurs_in(var, exprt) or occurs_in(var, exprf) + } + + (M.lambda(params, body)) { + // lambda(list(string), expr) + let vars = list.map(fn (str) { M.var(str) }, params); + in + if (list.member(var, vars)) { + false + } else { + occurs_in(var, body) + } + } + + (M.letrec_expr(bindings, expr)) { + // letrec_expr(list(#(string, expr)), expr) + let #(strs, exprs) = list.unzip(bindings); + vars = list.map(fn (s) { M.var(s) }, strs); + in + if (list.member(var, vars)) { + false + } else { + list.any(occurs_in(var), exprs) or occurs_in(var, expr) + } + } + + (M.lookup(name, index, expr)) { + // lookup(string, number, expr) + occurs_in(var, expr) + } + + (M.make_vec(size, args)) { + // make_vec(number, list(expr)) + list.any(occurs_in(var), args) + } + + (M.match_cases(test, cases)) { + // match_cases(expr, list(#(list(number), expr))) + let #(vals, results) = list.unzip(cases); + in + list.any(occurs_in(var), results) + } + + (M.namespaces(exprs)) { + // namespaces(list(expr)) + list.any(occurs_in(var), exprs) + } + + (M.sequence(exprs)) { + // sequence(list(expr)) + list.any(occurs_in(var), exprs) + } + + (x) { + M.print_expr(x); + puts("\n"); + error("occurs_in: unsupported expression") + } + } +} + +fn reduce { + (M.amb_expr(expr1, expr2)) { + // amb_expr(expr, expr) + M.amb_expr(reduce(expr1), reduce(expr2)) + } + + (M.apply(fun, args)) { + // apply(expr, list(expr)) + M.apply(reduce(fun), list.map(reduce, args)) + } + + (x = M.back_expr) | + (x = M.primop(_)) | + (x = M.env_expr) | + (x = M.error_expr) | + (x = M.bigint(_)) | + (x = M.character(_)) | + (x = M.var(_)) | + (x = M.stdint(_)) { + x + } + + (M.callcc_expr(e)) { + // callcc_expr(expr) + M.callcc_expr(reduce(e)) + } + + (M.cond_expr(test, branches)) { + // cond_expr(expr, list(#(expr, expr))) + let #(vals, results) = list.unzip(branches); + in + M.cond_expr(reduce(test), + list.zip(list.map(reduce, vals), + list.map(reduce, results))) + } + + (M.if_expr(exprc, exprt, exprf)) { + // if_expr(expr, expr, expr) + M.if_expr(reduce(exprc), + reduce(exprt), + reduce(exprf)) + } + + (M.lambda(params, body)) { + // lambda(list(string), expr) + switch (body) { + (M.apply(f, args)) { + let pvars = list.map(fn (v) { M.var(v) }, params); + in + if (pvars == args and not list.any(fn (v) { occurs_in(v, f) }, pvars)) { + f + } else { + M.lambda(params, reduce(body)) + } + } + (_) { + M.lambda(params, reduce(body)) + } + } + } + + (M.letrec_expr(bindings, expr)) { + // letrec_expr(list(#(string, expr)), expr) + let #(vars, exprs) = list.unzip(bindings); + newexprs = list.map(reduce, exprs); + newbindings = list.zip(vars, newexprs); + in + M.letrec_expr(newbindings, reduce(expr)) + } + + (M.lookup(name, index, expr)) { + // lookup(string, number, expr) + M.lookup(name, index, reduce(expr)) + } + + (M.make_vec(size, args)) { + // make_vec(number, list(expr)) + M.make_vec(size, list.map(reduce, args)) + } + + (M.match_cases(test, cases)) { + // match_cases(expr, list(#(list(number), expr))) + let #(vals, results) = list.unzip(cases); + in + M.match_cases(reduce(test), + list.zip(vals, list.map(reduce, results))) + } + + (M.namespaces(exprs)) { + // namespaces(list(expr)) + M.namespaces(list.map(reduce, exprs)) + } + + (M.sequence(exprs)) { + // sequence(list(expr)) + M.sequence(list.map(reduce, exprs)) + } + + (x) { + M.print_expr(x); + puts("\n"); + error("reduce: unsupported expression") + } +} \ No newline at end of file diff --git a/fn/rewrite/expr.fn b/fn/rewrite/expr.fn index f6322689..a7997672 100644 --- a/fn/rewrite/expr.fn +++ b/fn/rewrite/expr.fn @@ -2,11 +2,6 @@ namespace link "../listutils.fn" as list; typedef expr { - lambdac(list(string), expr) | - make_closure(expr, expr) | - make_env(list(#(string, expr))) | - env_ref(expr, string) | - apply_closure(expr, list(expr)) | amb_expr(expr, expr) | apply(expr, list(expr)) | back_expr | @@ -14,9 +9,9 @@ namespace callcc_expr(expr) | character(char) | cond_expr(expr, list(#(expr, expr))) | - constant(string) | + constant(string, number) | constructor_info(string) | - construct(string, list(expr)) | + construct(string, number, list(expr)) | deconstruct(string, number, expr) | env_expr | error_expr | @@ -79,59 +74,6 @@ namespace // Printer for expressions fn print_expr { - (x=lambdac(args, expr)) { - puts("(λ* ("); - print_list(args, puts, " "); - puts(") "); - print_expr(expr); - puts(")"); - x; - } - (x=make_closure(func, env)) { - puts("(CLO "); - print_expr(func); - puts(" "); - print_expr(env); - puts(")"); - x; - } - (x=make_env(bindings)) { - puts("{ "); - print_list(bindings, fn(#(name, expr)) { - puts(name); - switch (expr) { - (var(name2)) { - if (name == name2) { - "" - } else { - puts(": "); - print_expr(expr); - "" - } - } - (_) { - puts(": "); - print_expr(expr); - "" - } - } - }, ", "); - puts(" }"); - x; - } - (x=env_ref(env, name)) { - print_expr(env); - puts("."); - puts(name); - x; - } - (x=apply_closure(closure, args)) { - puts("(A/C "); - print_expr(closure); - print_sequence(args); - puts(")"); - x; - } (x=callcc_expr(e)) { puts("(call/cc "); print_expr(e); @@ -262,16 +204,20 @@ namespace puts(")"); x; } - (x=construct(name, args)) { + (x=construct(name, tg, args)) { puts("(construct "); puts(name); + putc(' '); + putn(tg); print_sequence(args); puts(")"); x; } - (x=constant(name)) { + (x=constant(name, tg)) { puts("(constant "); puts(name); + putc(' '); + putn(tg); puts(")"); x; } @@ -400,9 +346,9 @@ namespace fn to_expr { (atom("back")) { back_expr } - (atom("true")) { constant("true") } - (atom("false")) { constant("false") } - (atom("null")) { constant("null") } + (atom("true")) { constant("true", 1) } + (atom("false")) { constant("false", 0) } + (atom("null")) { constant("null", 0) } (atom(['\'', c, '\''])) { character(c) } (sexp([atom("env")])) { env_expr } (sexp([atom("error")])) { error_expr } @@ -418,12 +364,18 @@ namespace (sexp([e1, e2])) { #(to_expr(e1), to_expr(e2)) } (_) { error("Invalid cond branch") } }, branches)) } - (sexp([atom("constant"), atom(name)])) { constant(name) } + (sexp([atom("constant"), atom(name), atom(tg)])) { constant(name, to_number(tg)) } (sexp([atom("constructor_info"), atom(name)])) { constructor_info(name) } - (sexp(atom("construct") @ atom(name) @ args)) { construct(name, list.map(to_expr, args)) } - (sexp([atom("deconstruct"), atom(name), atom(index), e])) { deconstruct(name, to_number(index), to_expr(e)) } + (sexp(atom("construct") @ atom(name) @ atom(tg) @ args)) { + construct(name, to_number(tg), list.map(to_expr, args)) + } + (sexp([atom("deconstruct"), atom(name), atom(index), e])) { + deconstruct(name, to_number(index), to_expr(e)) + } (sexp([atom("lambda"), sexp(args), body])) | - (sexp([atom("\u03bb;"), sexp(args), body])) { lambda(list.map(atom_to_string, args), to_expr(body)) } + (sexp([atom("\u03bb;"), sexp(args), body])) { + lambda(list.map(atom_to_string, args), to_expr(body)) + } (sexp(atom("begin") @ exprs)) { sequence(list.map(to_expr, exprs)) } (sexp([atom("let"), sexp(bindings), body])) { let bindingsList = list.map (fn { @@ -468,6 +420,7 @@ namespace (sexp([atom("-"), e1, e2])) { primapp("-", to_expr(e1), to_expr(e2)) } (sexp([atom("*"), e1, e2])) { primapp("*", to_expr(e1), to_expr(e2)) } (sexp([atom("/"), e1, e2])) { primapp("/", to_expr(e1), to_expr(e2)) } + (sexp([atom("%"), e1, e2])) { primapp("%", to_expr(e1), to_expr(e2)) } (sexp([atom("**"), e1, e2])) { primapp("**", to_expr(e1), to_expr(e2)) } (sexp([atom("=="), e1, e2])) { primapp("==", to_expr(e1), to_expr(e2)) } (sexp([atom("="), e1, e2])) { primapp("=", to_expr(e1), to_expr(e2)) } @@ -475,7 +428,6 @@ namespace (sexp([atom(">"), e1, e2])) { primapp(">", to_expr(e1), to_expr(e2)) } (sexp([atom("<="), e1, e2])) { primapp("<=", to_expr(e1), to_expr(e2)) } (sexp([atom(">="), e1, e2])) { primapp(">=", to_expr(e1), to_expr(e2)) } - (sexp([atom("set!"), e1, e2])) { primapp("set!", to_expr(e1), to_expr(e2)) } (sexp([atom("print"), e])) { print_exp(to_expr(e)) } (sexp([atom("tag"), e])) { tag(to_expr(e)) } (sexp([atom("tuple_index"), atom(size), atom(index), e])) { tuple_index(1, 1, to_expr(e)) } diff --git a/fn/rewrite/freevars.fn b/fn/rewrite/freevars.fn index 4d4b6bab..ac066448 100644 --- a/fn/rewrite/freevars.fn +++ b/fn/rewrite/freevars.fn @@ -1,82 +1,63 @@ namespace -link "expr.fn" as E; +link "minexpr.fn" as M; link "../listutils.fn" as list; // free: expr -> list(string) fn free { // amb_expr(expr, expr) - (E.amb_expr(e1, e2)) { + (M.amb_expr(e1, e2)) { list.unique(free(e1) @@ free(e2)) } // apply[_closure](expr, list(expr)) - (E.apply_closure(f, args)) | (E.apply(f, args)) { + (M.apply_closure(f, args)) | (M.apply(f, args)) { list.unique(list.concat(free(f) @ list.map(free, args))) } - // back_expr - (E.back_expr) | - // bigint(number) - (E.bigint(_)) | - // character(char) - (E.character(_)) | - // constant(string) - (E.constant(_)) | - // constructor_info(string) - (E.constructor_info(_)) | - // env_expr - (E.env_expr) | - // error_expr - (E.error_expr) | - // stdint(number) - (E.stdint(_)) { [] } + (M.back_expr) | + (M.bigint(_)) | + (M.primop(_)) | + (M.character(_)) | + (M.env_expr) | + (M.error_expr) | + (M.stdint(_)) { [] } // callcc_expr(expr) - (E.callcc_expr(e)) { + (M.callcc_expr(e)) { free(e) } // env_ref(expr, string) - (E.env_ref(e, s)) { + (M.env_ref(e, s)) { free(e) } // cond_expr(expr, list(#(expr, expr))) - (E.cond_expr(test, branches)) { + (M.cond_expr(test, branches)) { list.unique(free(test) @@ list.concat(list.map(fn (#(cond, res)) { list.unique(free(cond) @@ free(res)) }, branches))) } - // construct(string, list(expr)) - (E.construct(tag, fields)) { - list.unique(list.concat(list.map(free, fields))) - } - - // deconstruct(string, number, expr) - (E.deconstruct(tag, n, e)) { - free(e) - } - // env_ref(expr, string) - (E.env_ref(e, s)) { + (M.env_ref(e, s)) { free(e) } // if_expr(expr, expr, expr) - (E.if_expr(cond, then_branch, else_branch)) { + (M.if_expr(cond, then_branch, else_branch)) { list.unique(free(cond) @@ free(then_branch) @@ free(else_branch)) } // lambda[c](list(string), expr) - (E.lambda(params, body)) | (E.lambdac(params, body)) { + (M.lambda(params, body)) | (M.lambdac(params, body)) { list.exclude(params, free(body)) } // letrec_expr(list(#(string, expr)), expr) - (E.letrec_expr(bindings, body)) { + (M.letrec_expr(bindings, body)) { let #(names, exprs) = list.unzip(bindings); in @@ -84,83 +65,48 @@ fn free { } // lookup(string, number, expr) - (E.lookup(s, n, e)) { + (M.lookup(s, n, e)) { free(e) } // make_closure(expr, expr) - (E.make_closure(fun, env)) { + (M.make_closure(fun, env)) { list.unique(free(fun) @@ free(env)); } // make_env(list(#(string, expr))) - (E.make_env(bindings)) { + (M.make_env(bindings)) { let #(vs, es) = list.unzip(bindings); in list.unique(list.concat(list.map(free, es))) } - // make_tuple(list(expr)) - (E.make_tuple(elements)) { - list.unique(list.concat(list.map(free, elements))) - } - // make_vec(number, list(expr)) - (E.make_vec(n, elements)) { + (M.make_vec(n, elements)) { list.unique(list.concat(list.map(free, elements))) } // match_cases(expr, list(#(list(number), expr))) - (E.match_cases(scrutinee, cases)) { + (M.match_cases(scrutinee, cases)) { list.unique(free(scrutinee) @@ list.concat(list.map(fn (#(nums, e)) { free(e) }, cases))) } // namespaces(list(expr)) - (E.namespaces(exprs)) { + (M.namespaces(exprs)) { list.unique(list.concat(list.map(free, exprs))) } - // primapp(string, expr, expr) - (E.primapp(op, e1, e2)) { - list.unique(free(e1) @@ free(e2)) - } - - // print_exp(expr) - (E.print_exp(e)) { - free(e) - } - // sequence(list(expr)) - (E.sequence(exps)) { + (M.sequence(exps)) { list.unique(list.concat(list.map(free, exps))) } - // tag(expr) - (E.tag(e)) { - free(e) - } - - // tuple_index(number, number, expr) - (E.tuple_index(n1, n2, e)) { - free(e) - } - - // typedefs(number, expr) - (E.typedefs(n, e)) { - free(e) - } - - // typeof_expr(expr) - (E.typeof_expr(e)) { - free(e) - } - // var(string) - (E.var(v)) { [v] } + (M.var(v)) { [v] } (e) { - E.print_expr(e); + M.print_expr(e); puts(": "); error("unhandled expr type"); } diff --git a/fn/rewrite/infer.fn b/fn/rewrite/infer.fn index 7b81a48b..87dae64d 100644 --- a/fn/rewrite/infer.fn +++ b/fn/rewrite/infer.fn @@ -149,7 +149,7 @@ let fn funType(dom, cod) { operType("->", [dom, cod]) } fn analyzeExp { - (ExpClass(ide), envt, ng) { retrieve(ide, envt, ng) } + (ideClass(ide), envt, ng) { retrieve(ide, envt, ng) } (condClass(test, cons, alt), envt, ng) { unifyType(test, boolType) and unifyType(analyzeExp(cons, envt, ng), analyzeExp(alt, envt, ng)) diff --git a/fn/rewrite/minexpr.fn b/fn/rewrite/minexpr.fn new file mode 100644 index 00000000..7999c958 --- /dev/null +++ b/fn/rewrite/minexpr.fn @@ -0,0 +1,404 @@ +namespace + // minexpr: somewhat reduced expression set output by desugaring and used by later passes + link "../listutils.fn" as list; + + typedef expr { + amb_expr(expr, expr) | + apply_closure(expr, list(expr)) | + apply(expr, list(expr)) | + back_expr | + bigint(number) | + callcc_expr(expr) | + character(char) | + cond_expr(expr, list(#(expr, expr))) | + env_expr | + env_ref(expr, string) | + error_expr | + if_expr(expr, expr, expr) | + lambdac(list(string), expr) | + lambda(list(string), expr) | + letrec_expr(list(#(string, expr)), expr) | + lookup(string, number, expr) | + make_closure(expr, expr) | + make_env(list(#(string, expr))) | + make_vec(number, list(expr)) | + match_cases(expr, list(#(list(number), expr))) | + namespaces(list(expr)) | + primop(string) | + sequence(list(expr)) | + stdint(number) | + var(string) + } + + // Helper printers + fn print_list(indices, putter, space) { + switch (indices) { + ([]) { "" } + (h @ t) { + putter(h); + list.for_each (fn(i) { puts(space); putter(i) }, t); + "" + } + }; + } + + fn print_bindings(bindings) { + print_list(bindings, fn(#(name, expr)) { + putc('('); + puts(name); + putc(' '); + print_expr(expr); + putc(')'); + }, " "); + } + + fn print_let(name, bindings, body) { + puts("("); + puts(name); + puts(" ["); + print_bindings(bindings); + puts("] "); + print_expr(body); + puts(")"); + } + + fn print_sequence(exprs) { + list.map (fn(e) { puts(" "); print_expr(e) }, exprs); + } + + // Printer for expressions + fn print_expr { + (x=lambdac(args, expr)) { + puts("(λ* ("); + print_list(args, puts, " "); + puts(") "); + print_expr(expr); + puts(")"); + x; + } + (x=make_closure(func, env)) { + puts("(CLO "); + print_expr(func); + puts(" "); + print_expr(env); + puts(")"); + x; + } + (x=make_env(bindings)) { + puts("{ "); + print_list(bindings, fn(#(name, expr)) { + puts(name); + switch (expr) { + (var(name2)) { + if (name == name2) { + "" + } else { + puts(": "); + print_expr(expr); + "" + } + } + (_) { + puts(": "); + print_expr(expr); + "" + } + } + }, ", "); + puts(" }"); + x; + } + (x=env_ref(env, name)) { + print_expr(env); + puts("->"); + puts(name); + x; + } + (x=apply_closure(closure, args)) { + puts("(A/C "); + print_expr(closure); + print_sequence(args); + puts(")"); + x; + } + (x=callcc_expr(e)) { + puts("(call/cc "); + print_expr(e); + puts(")"); + x; + } + (x=stdint(i)) { + putn(i); + x; + } + (x=sequence(exprs)) { + puts("(begin"); + print_sequence(exprs); + puts(")"); + x; + } + (x=namespaces(exprs)) { + puts("(namespaces"); + print_sequence(exprs); + puts(")"); + x; + } + (x=match_cases(exp, cases)) { + puts("(match-cases "); + print_expr(exp); + list.for_each (fn { + (#(indices, caseExpr)) { + puts(" (("); + print_list(indices, fn(i) { putn(i) }, " "); + puts(") "); + print_expr(caseExpr); + puts(")"); + } + }, cases); + puts(")"); + x; + } + (x=make_vec(size, elements)) { + puts("(make-vec "); + putn(size); + print_sequence(elements); + puts(")"); + x; + } + (x=lookup(name, index, expr)) { + puts("(lookup "); + puts(name); + puts(" "); + putn(index); + puts(" "); + print_expr(expr); + puts(")"); + x; + } + (x=env_expr) { + puts("(env)"); + x; + } + (x=error_expr) { + puts("(error)"); + x; + } + (x=cond_expr(test, branches)) { + puts("(cond "); + print_expr(test); + list.for_each (fn { + (#(e1, e2)) { + puts(" "); + putc('('); + print_expr(e1); + puts(" "); + print_expr(e2); + putc(')'); + } + }, branches); + puts(")"); + x; + } + (x=letrec_expr(bindings, body)) { + print_let("letrec", bindings, body); + x; + } + (x=lambda(args, expr)) { + puts("(λ ("); + print_list(args, fn(name) { puts(name) }, " "); + puts(") "); + print_expr(expr); + puts(")"); + x; + } + (x=if_expr(e1, e2, e3)) { + puts("(if "); + print_expr(e1); + puts(" "); + print_expr(e2); + puts(" "); + print_expr(e3); + puts(")"); + x; + } + (x=apply(e1, args)) { + puts("("); + print_expr(e1); + print_sequence(args); + puts(")"); + x; + } + (x=bigint(i)) { + putn(i); + x; + } + (x=var(chars)) { + puts(chars); + x; + } + (x=amb_expr(e1, e2)) { + puts("(amb "); + print_expr(e1); + puts(" "); + print_expr(e2); + puts(")"); + x; + } + (x=back_expr) { + puts("(back)"); + x; + } + (x=character(c)) { + putc('\''); + putc(c); + putc('\''); + x; + } + (x=primop(name)) { + puts(name); + x; + } + } + + // A *very* dumb parser for basic s-expressions + fn parse(s) { + let + // parser "tokens" + typedef sexpr { + atom(string) | + sexp(list(sexpr)) + } + + fn to_number(s) { + let + fn to_digit { + ('0') { 0 } + ('1') { 1 } + ('2') { 2 } + ('3') { 3 } + ('4') { 4 } + ('5') { 5 } + ('6') { 6 } + ('7') { 7 } + ('8') { 8 } + ('9') { 9 } + (_) { error("Invalid digit") } + } + fn helper { + ([], acc) { acc } + (c @ rest, acc) { + let + digit = to_digit(c); + in + helper(rest, acc * 10 + digit); + } + } + in + helper(s, 0) + } + + fn atom_to_string { + (atom(s)) { s } + (_) { error("Expected atom") } + } + + fn to_expr { + (atom("back")) { back_expr } + (atom(['\'', c, '\''])) { character(c) } + (sexp([atom("env")])) { env_expr } + (sexp([atom("error")])) { error_expr } + (atom(x = '0' @ rest)) | (atom(x = '1' @ rest)) | (atom(x = '2' @ rest)) | + (atom(x = '3' @ rest)) | (atom(x = '4' @ rest)) | (atom(x = '5' @ rest)) | + (atom(x = '6' @ rest)) | (atom(x = '7' @ rest)) | (atom(x = '8' @ rest)) | + (atom(x = '9' @ rest)) { bigint(to_number(x))} + (atom(s)) { var(s) } + (sexp([atom("amb"), a, b])) { amb_expr(to_expr(a), to_expr(b)) } + (sexp([atom("call/cc"), e])) { callcc_expr(to_expr(e)) } + (sexp([atom("if"), e1, e2, e3])) { if_expr(to_expr(e1), to_expr(e2), to_expr(e3)) } + (sexp(atom("cond") @ test @ branches)) { cond_expr(to_expr(test), list.map (fn { + (sexp([e1, e2])) { #(to_expr(e1), to_expr(e2)) } + (_) { error("Invalid cond branch") } + }, branches)) } + (sexp([atom("lambda"), sexp(args), body])) | + (sexp([atom("\u03bb;"), sexp(args), body])) { lambda(list.map(atom_to_string, args), to_expr(body)) } + (sexp(atom("begin") @ exprs)) { sequence(list.map(to_expr, exprs)) } + (sexp([atom("letrec"), sexp(bindings), body])) { + let bindingsList = list.map (fn { + (sexp([atom(name), expr])) { #(name, to_expr(expr)) } + (_) { error("Invalid letrec binding") } + }, bindings); + in + letrec_expr(bindingsList, to_expr(body)) + } + (sexp([atom("lookup"), atom(name), atom(index), e])) { lookup(name, to_number(index), to_expr(e)) } + (sexp(atom("make_vec") @ atom(size) @ elements)) { make_vec(to_number(size), list.map(to_expr, elements)) } + (sexp(atom("match_cases") @ exp @ cases)) { match_cases(to_expr(exp), list.map (fn { + (sexp([sexp(indices), caseExpr])) { + let indexList = list.map (fn { + (atom(i)) { to_number(i) } + (_) { error("Invalid match_cases index") } + }, indices); + in + #(indexList, to_expr(caseExpr)) + } + (_) { error("Invalid match_cases case") } + }, cases)) } + (sexp(atom("namespaces") @ exprs)) { namespaces(list.map(to_expr, exprs)) } + (sexp([atom("+"), e1, e2])) { apply(primop("+"), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("-"), e1, e2])) { apply(primop("-"), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("*"), e1, e2])) { apply(primop("*"), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("/"), e1, e2])) { apply(primop("/"), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("**"), e1, e2])) { apply(primop("**"), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("=="), e1, e2])) { apply(primop("=="), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("="), e1, e2])) { apply(primop("="), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("<"), e1, e2])) { apply(primop("<"), [to_expr(e1), to_expr(e2)]) } + (sexp([atom(">"), e1, e2])) { apply(primop(">"), [to_expr(e1), to_expr(e2)]) } + (sexp([atom("<="), e1, e2])) { apply(primop("<="), [to_expr(e1), to_expr(e2)]) } + (sexp([atom(">="), e1, e2])) { apply(primop(">="), [to_expr(e1), to_expr(e2)]) } + (sexp([])) { error("Empty expression") } + (sexp(func @ args)) { apply(to_expr(func), list.map(to_expr, args)) } + (x) { + print x; + error("Cannot parse expression"); + } + } + + // Tokenizer function + fn parse_sexpr(s) { + let + fn parse_atom { + ([], acc) { #(atom(list.reverse(acc)), []) } + (' ' @ rest, acc) { #(atom(list.reverse(acc)), rest) } + (')' @ rest, acc) { #(atom(list.reverse(acc)), ')' @ rest) } + (c @ rest, acc) { parse_atom(rest, c @ acc) } + } + + fn parse_list { + ([], _) { error("Unexpected end of input") } + (')' @ rest, acc) { #(sexp(list.reverse(acc)), rest) } + (' ' @ rest, acc) { parse_list(rest, acc) } + (input, acc) { + let + #(sexpr, rest) = parse_sexpr(input); + in + parse_list(rest, sexpr @ acc) + } + } + in + switch (s) { + ([]) { error("Unexpected end of input") } + ('(' @ rest) { parse_list(rest, []) } + (' ' @ rest) { parse_sexpr(rest) } + (')' @ rest) { error("Unexpected )") } + (c @ rest) { parse_atom(rest, [c]) } + } + } + in { + let #(sexpr, rest) = parse_sexpr(s); + in if (list.empty(rest)) { + to_expr(sexpr); + } else { + error("Extra input after expression: " @@ rest); + } + } + } \ No newline at end of file diff --git a/fn/rewrite/normalize.fn b/fn/rewrite/normalize.fn index 8bbb8254..1da7f843 100644 --- a/fn/rewrite/normalize.fn +++ b/fn/rewrite/normalize.fn @@ -1,16 +1,14 @@ -let +namespace link "../listutils.fn" as list; - link "desugar.fn" as DS; - link "samples.fn" as Samples; link "../ioutils.fn" as io; - link "expr.fn" as E; + link "minexpr.fn" as M; import io operator "$_"; // Normalization algorithm fn genstring() { "$" @@ $incr() } - fn gensym() { E.var(genstring()) } + fn gensym() { M.var(genstring()) } fn normalize_term (e) { normalize(e, fn (x) { x }) } @@ -31,169 +29,114 @@ let fn normalize_name(e, k) { normalize(e, fn { - (x=E.bigint(_)) | - (x=E.var(_)) | - (x=E.back_expr) | - (x=E.constant(_)) | - (x=E.constructor_info(_)) | - (x=E.stdint(_)) | - (x=E.env_expr) | - (x=E.error_expr) | - (x=E.character(_)) { + (x=M.bigint(_)) | + (x=M.var(_)) | + (x=M.back_expr) | + (x=M.stdint(_)) | + (x=M.env_expr) | + (x=M.error_expr) | + (x=M.character(_)) { k(x) } (x) { - let - y = genstring(); - in - DS.desugar(E.let_expr([#(y, x)], k(E.var(y)))) + let y = genstring(); + in M.apply(M.lambda([y], k(M.var(y))), [x]) } }) } fn normalize { - - (E.lambda(params, body), k) { - k(E.lambda(params, normalize_term(body))) - } - - (x=E.bigint(_), k) | - (x=E.var(_), k) | - (x=E.back_expr, k) | - (x=E.constant(_), k) | - (x=E.stdint(_), k) | - (x=E.constructor_info(_), k) | - (x=E.env_expr, k) | - (x=E.error_expr, k) | - (x=E.character(_), k) { + (M.lambda(params, body), k) { + k(M.lambda(params, normalize_term(body))) + } + + (x=M.bigint(_), k) | + (x=M.primop(_), k) | + (x=M.var(_), k) | + (x=M.back_expr, k) | + (x=M.stdint(_), k) | + (x=M.env_expr, k) | + (x=M.error_expr, k) | + (x=M.character(_), k) { k(x) } - (E.callcc_expr(e), k) { + (M.callcc_expr(e), k) { normalize_name(e, fn (t) { - k(E.callcc_expr(t)) + k(M.callcc_expr(t)) }) } // the branches of the if must be contained - (E.if_expr(e0, e1, e2), k) { + (M.if_expr(e0, e1, e2), k) { normalize_name(e0, fn (test) { - k(E.if_expr(test, normalize_term(e1), normalize_term(e2))) + k(M.if_expr(test, normalize_term(e1), normalize_term(e2))) }) } - (E.apply(Fn, Ms), k) { - normalize_name(Fn, fn (t) { - normalize_names(Ms, fn (ts) { - k(E.apply(t, ts)) - }) - }) - } - - (E.construct(name, args), k) { - normalize_names(args, fn (ts) { - k(E.construct(name, ts)) + (M.apply(M.primop(op), Ms), k) { + normalize_names(Ms, fn (ts) { + k(M.apply(M.primop(op), ts)) }) } - (E.make_tuple(Ms), k) { - normalize_names(Ms, fn (ts) { - k(E.make_tuple(ts)) + (M.apply(Fn, Ms), k) { + normalize_name(Fn, fn (t) { + normalize_names(Ms, fn (ts) { + k(M.apply(t, ts)) + }) }) } - (E.sequence(Ms), k) { - k(E.sequence(normalize_terms(Ms))) + (M.sequence(Ms), k) { + k(M.sequence(normalize_terms(Ms))) } - (E.make_vec(size, Ms), k) { + (M.make_vec(size, Ms), k) { normalize_names(Ms, fn (ts) { - k(E.make_vec(size, ts)) + k(M.make_vec(size, ts)) }) } - (E.letrec_expr(Bs, body), k) { + (M.letrec_expr(Bs, body), k) { normalizeBindings(Bs, fn (bs) { - E.letrec_expr(bs, normalize(body, k)) + M.letrec_expr(bs, normalize(body, k)) }) } // amb expression evaluation must be contained - (E.amb_expr(e1, e2), k) { - k(E.amb_expr(normalize_term(e1), normalize_term(e2))) + (M.amb_expr(e1, e2), k) { + k(M.amb_expr(normalize_term(e1), normalize_term(e2))) } // branches of a cond must be individually contained - (E.cond_expr(e0, branches), k) { - normalize_name(e0, fn (t) { - k(E.cond_expr(t, normalize_cases(branches))) - }) - } - - // same for E.match_cases - (E.match_cases(e0, branches), k) { + (M.cond_expr(e0, branches), k) { normalize_name(e0, fn (t) { - k(E.match_cases(t, normalize_cases(branches))) + k(M.cond_expr(t, normalize_cases(branches))) }) } - (E.deconstruct(name, index, e0), k) { + // same for M.match_cases + (M.match_cases(e0, branches), k) { normalize_name(e0, fn (t) { - k(E.deconstruct(name, index, t)) + k(M.match_cases(t, normalize_cases(branches))) }) } // we have to treat e0 as a Cexp because it is // inside the scope of a namespace - (E.lookup(name, index, e0), k) { - k(E.lookup(name, index, (normalize_term(e0)))) + (M.lookup(name, index, e0), k) { + k(M.lookup(name, index, (normalize_term(e0)))) } // each namespace must be individually contained - (E.namespaces(exprs), k) { - k(E.namespaces(normalize_terms(exprs))) - } - - // the typedefs themselves are discarded after normalization - (E.typedefs(ignored, expr), k) { - k(E.typedefs(ignored, normalize_term(expr))) - } - - (E.primapp(name, e1, e2), k) { - normalize_name(e1, fn (t1) { - normalize_name(e2, fn (t2) { - k(E.primapp(name, t1, t2)) - }) - }) - } - - (E.print_exp(e0), k) { - normalize_name(e0, fn (t) { - k(E.print_exp(t)) - }) - } - - (E.typeof_expr(e0), k) { - normalize_name(e0, fn (t) { - k(E.typeof_expr(t)) - }) - } - - (E.tuple_index(size, index, e0), k) { - normalize_name(e0, fn (t) { - k(E.tuple_index(size, index, t)) - }) - } - - (E.tag(e0), k) { - normalize_name(e0, fn (t) { - k(E.tag(t)) - }) + (M.namespaces(exprs), k) { + k(M.namespaces(normalize_terms(exprs))) } (other, k) { // catch-all for unhandled expressions - E.print_expr(other); + M.print_expr(other); puts(": "); error("normalize: unhandled expression"); } @@ -222,14 +165,4 @@ let }) }) } - } -in - list.for_each (fn (str) { - let expr = E.parse(str); - in - E.print_expr(expr); - puts(" ==>\n "); - E.print_expr(normalize_term(DS.desugar(expr))); - puts("\n") - }, - Samples.data); \ No newline at end of file + } \ No newline at end of file diff --git a/fn/rewrite/pettersson92.fn b/fn/rewrite/pettersson92.fn index 0c1b31aa..9ce72737 100644 --- a/fn/rewrite/pettersson92.fn +++ b/fn/rewrite/pettersson92.fn @@ -224,7 +224,7 @@ let #(tagged(base, wildcard), dict.insert(name, base, d)) } - (some(other)) { + (just(other)) { #(tagged(base, comparison(other)), d) } } @@ -268,7 +268,7 @@ let let fn h { (symbol(s)) { switch (dict.lookup(s, substs)) { - (some(v)) { symbol(v) } + (just(v)) { symbol(v) } (nothing) { symbol(s) } } } @@ -541,7 +541,7 @@ let (s = final(_, _, _, _, _), d) { let label = makeLabel(s); in switch (dict.lookup(label, d)) { - (some(rc)) { dict.insert(label, rc + 1, d) } + (just(rc)) { dict.insert(label, rc + 1, d) } (nothing) { dict.insert(label, 1, d) } } } @@ -555,7 +555,7 @@ let in collectArcs(arcs, d) => fn (d) { let label = makeLabel(s); in switch (dict.lookup(label, d)) { - (some(rc)) { dict.insert(label, rc + 1, d); } + (just(rc)) { dict.insert(label, rc + 1, d); } (nothing) { dict.insert(label, 1, d); } } } @@ -569,7 +569,7 @@ let let fn getRc(s) { switch(dict.lookup(makeLabel(s), rcs)) { - (some(n)) { n } + (just(n)) { n } (nothing) { 0 } }; } diff --git a/fn/rewrite/pratt.fn b/fn/rewrite/pratt.fn index c8c9ebc1..6a4ecb52 100644 --- a/fn/rewrite/pratt.fn +++ b/fn/rewrite/pratt.fn @@ -27,12 +27,12 @@ let (lhs, nothing, lexer) { #(lhs, lexer) } - (lhs, some(lex.Op(op)), lexer) { + (lhs, just(lex.Op(op)), lexer) { infix_bp(op) => fn (#(l_bp, r_bp)) { if (l_bp < min_bp) { #(lhs, lexer) } else { - lex.next(lexer) => unsafe fn (some(#(_, lexer))) { + lex.next(lexer) => unsafe fn (just(#(_, lexer))) { expr_bp(lexer, r_bp) => fn (#(rhs, lexer)) { loop(exp.Cons(op, [lhs, rhs]), lex.peek(lexer), lexer) } @@ -46,10 +46,10 @@ let } in switch(lex.next(lexer)) { - (some(#(lex.Atom(it), lexer))) { + (just(#(lex.Atom(it), lexer))) { loop(exp.Atom(it), lex.peek(lexer), lexer) } - (some(#(lex.Op(it), lexer))) { + (just(#(lex.Op(it), lexer))) { expr_bp(lexer, prefix_bp(it)) => fn (#(rhs, lexer)) { loop(exp.Cons(it, [rhs]), lex.peek(lexer), lexer) } diff --git a/fn/rewrite/pratt_lexer.fn b/fn/rewrite/pratt_lexer.fn index 218f107c..c3553d1d 100644 --- a/fn/rewrite/pratt_lexer.fn +++ b/fn/rewrite/pratt_lexer.fn @@ -24,11 +24,11 @@ fn new (str) { } fn next { - (Lexer(h @ t)) { some(#(h, Lexer(t))) } + (Lexer(h @ t)) { just(#(h, Lexer(t))) } (Lexer([])) { nothing } } fn peek { - (Lexer(h @ _)) { some(h) } + (Lexer(h @ _)) { just(h) } (Lexer([])) { nothing } } diff --git a/fn/rewrite/samples.fn b/fn/rewrite/samples.fn index f1c926ae..ecbb9707 100644 --- a/fn/rewrite/samples.fn +++ b/fn/rewrite/samples.fn @@ -1,233 +1,401 @@ namespace - data = [ - // Basic application - "(g a)" + fn data() {[ + ";Basic application", + "(g a)", - // Simple λ application - ,"((λ (x) (h x)) (g 4))" + ";Simple λ application", + "((λ (x) (h x)) (g 4))", - // Lambda definition with primitives - ,"(λ (a b) (+ a (* b 2)))" + ";Lambda definition with primitives", + "(λ (a b) (+ a (* b 2)))", - // Lambda application with primitives - nested - ,"((λ (a b) (+ a (* b 2))) 3 4)" + ";Lambda application with primitives - nested", + "((λ (a b) (+ a (* b 2))) 3 4)", - // Lambda application with function call in primitive - ,"((λ (a b) (+ a (* (f b) 2))) 3 4)" + ";Lambda application with function call in primitive", + "((λ (a b) (+ a (* (f b) 2))) 3 4)", - // Amb operator (non-determinism) - ,"(amb 1 2)" + ";Amb operator (non-determinism)", + "(amb 1 2)", - // Simple call/cc - immediate escape - ,"(call/cc (λ (k) (k 5)))" + ";Simple call/cc - immediate escape", + "(call/cc (λ (k) (k 5)))", - // call/cc that doesn't escape - ,"(call/cc (λ (k) 42))" + ";call/cc that doesn't escape", + "(call/cc (λ (k) 42))", - // call/cc with computation before escape - ,"(call/cc (λ (k) (+ 10 (k 5))))" + ";call/cc with computation before escape", + "(call/cc (λ (k) (+ 10 (k 5))))", - // Nested call/cc - ,"(call/cc (λ (k1) (call/cc (λ (k2) (k1 (k2 7))))))" + ";Nested call/cc", + "(call/cc (λ (k1) (call/cc (λ (k2) (k1 (k2 7))))))", - // call/cc with amb - ,"(call/cc (λ (k) (amb (k 1) (k 2))))" + ";call/cc with amb", + "(call/cc (λ (k) (amb (k 1) (k 2))))", - // Factorial with letrec - ,"(letrec ((fact (λ (n) (if (= n 0) 1 (* n (fact (- n 1))))))) (fact 5))" + ";Factorial with letrec", + "(letrec ((fact (λ (n) (if (= n 0) 1 (* n (fact (- n 1))))))) (fact 5))", - // Multiple argument function - ,"((λ (x y z) (+ x (+ y z))) 1 2 3)" + ";Multiple argument function", + "((λ (x y z) (+ x (+ y z))) 1 2 3)", - // Nested lambdas (currying) - ,"((λ (x) (λ (y) (+ x y))) 5)" + ";Nested lambdas (currying)", + "((λ (x) (λ (y) (+ x y))) 5)", - // Application of curried function - ,"(((λ (x) (λ (y) (+ x y))) 5) 3)" + ";Application of curried function", + "(((λ (x) (λ (y) (+ x y))) 5) 3)", - // If expression with complex branches - ,"(if (= x 0) (f 1) (g 2))" + ";If expression with complex branches", + "(if (= x 0) (f 1) (g 2))", - // If with nested if - ,"(if (= x 0) (if (= y 0) 1 2) 3)" + ";If with nested if", + "(if (= x 0) (if (= y 0) 1 2) 3)", - // Sequence (begin in Racket) - ,"(begin (f 1) (g 2) (h 3))" + ";Sequence (begin in Racket)", + "(begin (f 1) (g 2) (h 3))", - // Letrec with mutual recursion - ,"(letrec ((even (λ (n) (if (= n 0) true (odd (- n 1))))) (odd (λ (n) (if (= n 0) false (even (- n 1)))))) (even 5))" + ";Letrec with mutual recursion", + "(letrec ((even (λ (n) (if (= n 0) true (odd (- n 1))))) (odd (λ (n) (if (= n 0) false (even (- n 1)))))) (even 5))", - // Complex amb with computation - ,"(+ (amb 1 2) (amb 3 4))" + ";Complex amb with computation", + "(+ (amb 1 2) (amb 3 4))", - // Nested application - ,"(f (g (h x)))" + ";Nested application", + "(f (g (h x)))", - // Multiple primitives in sequence - ,"(+ (* 2 3) (- 5 1))" + ";Multiple primitives in sequence", + "(+ (* 2 3) (- 5 1))", - // call/cc capturing continuation in letrec - ,"(letrec ((k (λ () null))) (call/cc (λ (cont) (begin (set! k cont) 42))))" + ";Lambda with no arguments", + "((λ () 42))", - // Lambda with no arguments - ,"((λ () 42))" + ";call/cc with primitive operations", + "(call/cc (λ (k) (if (= 1 1) (k 10) 20)))", - // call/cc with primitive operations - ,"(call/cc (λ (k) (if (= 1 1) (k 10) 20)))" + ";Deeply nested primitives", + "(+ 1 (+ 2 (+ 3 (+ 4 5))))", - // Deeply nested primitives - ,"(+ 1 (+ 2 (+ 3 (+ 4 5))))" + ";Deeply nested primitives with a function call", + "(+ 1 (+ 2 (+ 3 (+ 4 (f 5)))))", - // Deeply nested primitives with a function call - ,"(+ 1 (+ 2 (+ 3 (+ 4 (f 5)))))" + ";Application with multiple complex arguments", + "(f (g a) (h b) (i c))", - // Application with multiple complex arguments - ,"(f (g a) (h b) (i c))" + ";If where branches have applications", + "(if test (f (g x)) (h (i y)))", - // If where branches have applications - ,"(if test (f (g x)) (h (i y)))" + ";Sequence with amb", + "(begin (amb 1 2) (amb 3 4))", - // Sequence with amb - ,"(begin (amb 1 2) (amb 3 4))" + ";call/cc that passes continuation to another function", + "(call/cc (λ (k) (f k)))", - // call/cc that passes continuation to another function - ,"(call/cc (λ (k) (f k)))" + ";cond expression - like switch/case", + "(cond x (1 (result1)) (2 (result2)) (3 (result3)))", - // cond expression - like switch/case - ,"(cond x (1 (result1)) (2 (result2)) (3 (result3)))" + ";cond with complex test and results", + "(cond (f x) (1 (g 1)) (2 (h 2)))", - // cond with complex test and results - ,"(cond (f x) (1 (g 1)) (2 (h 2)))" + ";construct with atomic arguments", + "(construct pair 1 2)", - // construct with atomic arguments - ,"(construct pair 1 2)" + ";construct with complex arguments", + "(construct pair (f 1) (g 2))", - // construct with complex arguments - ,"(construct pair (f 1) (g 2))" + ";nested construct", + "(construct cons (f x) (construct cons (g y) (constant nil)))", - // nested construct - ,"(construct cons (f x) (construct cons (g y) (constant nil)))" + ";deconstruct with atomic argument", + "(deconstruct pair 0 p)", - // deconstruct with atomic argument - ,"(deconstruct pair 0 p)" + ";deconstruct with complex argument", + "(deconstruct pair 1 (f x))", - // deconstruct with complex argument - ,"(deconstruct pair 1 (f x))" + ";nested deconstruct", + "(deconstruct pair 0 (deconstruct pair 1 (f x)))", - // nested deconstruct - ,"(deconstruct pair 0 (deconstruct pair 1 (f x)))" + ";let with atomic value", + "(let ((x 42)) (f x))", - // let with atomic value - ,"(let ((x 42)) (f x))" + ";let with complex value", + "(let ((x (f 10))) (g x))", - // let with complex value - ,"(let ((x (f 10))) (g x))" + ";nested let", + "(let ((x (f 1)) (y (g x))) (h x y))", - // nested let - ,"(let ((x (f 1)) (y (g x))) (h x y))" + ";nested let*", + "(let* ((x (f 1)) (y (g x))) (h x y))", - // nested let* - ,"(let* ((x (f 1)) (y (g x))) (h x y))" + ";lookup with simple variable", + "(lookup ns 0 x)", - // lookup with simple variable - ,"(lookup ns 0 x)" + ";lookup with function call", + "(lookup ns 0 (f x))", - // lookup with function call - ,"(lookup ns 0 (f x))" + ";nested lookup", + "(f (lookup ns 0 (g x)))", - // nested lookup - ,"(f (lookup ns 0 (g x)))" + ";make_tuple with atomic args", + "(make_tuple 1 2 3)", - // make_tuple with atomic args - ,"(make_tuple 1 2 3)" + ";make_tuple with complex args", + "(make_tuple (f 1) (g 2))", - // make_tuple with complex args - ,"(make_tuple (f 1) (g 2))" + ";make_tuple with mixed args", + "(make_tuple x (f y) 42)", - // make_tuple with mixed args - ,"(make_tuple x (f y) 42)" + ";make_vec with atomic args", + "(make_vec 3 1 2 3)", - // make_vec with atomic args - ,"(make_vec 3 1 2 3)" + ";make_vec with complex args", + "(make_vec 2 (f 1) (g 2))", - // make_vec with complex args - ,"(make_vec 2 (f 1) (g 2))" + ";make_vec with mixed args", + "(make_vec 3 x (f y) 42)", - // make_vec with mixed args - ,"(make_vec 3 x (f y) 42)" + ";match_cases with atomic test", + "(match_cases x ((1 2) (result1)) ((3 4 5) (result2)))", - // match_cases with atomic test - ,"(match_cases x ((1 2) (result1)) ((3 4 5) (result2)))" + ";match_cases with complex test", + "(match_cases (f x) ((1) (g 1)) ((2) (h 2)))", - // match_cases with complex test - ,"(match_cases (f x) ((1) (g 1)) ((2) (h 2)))" + ";match_cases with complex results", + "(match_cases x ((1) (f 1)) ((2) (g 2)))", - // match_cases with complex results - ,"(match_cases x ((1) (f 1)) ((2) (g 2)))" + ";namespaces with atomic expressions", + "(namespaces x y z)", - // namespaces with atomic expressions - ,"(namespaces x y z)" + ";namespaces with complex expressions", + "(namespaces (f 1) (g 2))", - // namespaces with complex expressions - ,"(namespaces (f 1) (g 2))" + ";namespaces with mixed expressions", + "(namespaces x (f y) z)", - // namespaces with mixed expressions - ,"(namespaces x (f y) z)" + ";namespaces with letrec bodies returning env", + "(namespaces (letrec ((x (λ () 1)) (y (λ () 2))) (let* ((f 1) (g f)) (env))) (letrec ((a (λ () 3)) (b (λ () 4))) (env)))", - // namespaces with letrec bodies returning env - ,"(namespaces (letrec ((x (λ () 1)) (y (λ () 2))) (let* ((f 1) (g f)) (env))) (letrec ((a (λ () 3)) (b (λ () 4))) (env)))" + ";print_exp with atomic argument", + "(print x)", - // print_exp with atomic argument - ,"(print x)" + ";print_exp with complex argument", + "(print (f x))", - // print_exp with complex argument - ,"(print (f x))" + ";print_exp nested in computation", + "(+ (print (f x)) 10)", - // print_exp nested in computation - ,"(+ (print (f x)) 10)" + ";tag with atomic argument", + "(tag x)", - // tag with atomic argument - ,"(tag x)" + ";tag with complex argument", + "(tag (f x))", - // tag with complex argument - ,"(tag (f x))" + ";tag in cond test", + "(cond (tag (f x)) (1 (result1)) (2 (result2)))", - // tag in cond test - ,"(cond (tag (f x)) (1 (result1)) (2 (result2)))" + ";tuple_index with atomic tuple", + "(tuple_index 3 0 t)", - // tuple_index with atomic tuple - ,"(tuple_index 3 0 t)" + ";tuple_index with complex tuple", + "(tuple_index 2 1 (f x))", - // tuple_index with complex tuple - ,"(tuple_index 2 1 (f x))" + ";nested tuple_index", + "(tuple_index 2 0 (tuple_index 3 1 (f x)))", - // nested tuple_index - ,"(tuple_index 2 0 (tuple_index 3 1 (f x)))" + ";typedefs with simple expression", + "(typedefs 0 x)", - // typedefs with simple expression - ,"(typedefs 0 x)" + ";typedefs with letrec body", + "(typedefs 0 (letrec ((f (λ (x) (g x)))) (f 42)))", - // typedefs with letrec body - ,"(typedefs 0 (letrec ((f (λ (x) (g x)))) (f 42)))" - - // typedefs with complex body - ,"(typedefs 0 (f (g x)))" - - // typedefs wrapping letrec with env body - ,"(typedefs 0 (letrec ((x (λ () 1)) (y (λ () 2))) (env)))" - - // typeof_expr with atomic argument - ,"(typeof x)" - - // typeof_expr with complex argument - ,"(typeof (f x))" - - // typeof_expr in conditional - ,"(if (typeof (f x)) (g 1) (h 2))" - - // curried function application - ,"(letrec ((add (λ (x y) (+ x y)))) ((add 2) 3))" - - // more complex curried function application - ,"(letrec ((applyf (λ (f) (f 1))) (mul (λ (x y) (* x y)))) (applyf (mul 2)))" - ]; \ No newline at end of file + ";typedefs with complex body", + "(typedefs 0 (f (g x)))", + + ";typedefs wrapping letrec with env body", + "(typedefs 0 (letrec ((x (λ () 1)) (y (λ () 2))) (env)))", + + ";typeof_expr with atomic argument", + "(typeof x)", + + ";typeof_expr with complex argument", + "(typeof (f x))", + + ";typeof_expr in conditional", + "(if (typeof (f x)) (g 1) (h 2))", + + ";curried function application", + "(letrec ((add (λ (x y) (+ x y)))) ((add 2) 3))", + + ";more complex curried function application", + "(letrec ((applyf (λ (f) (f 1))) (mul (λ (x y) (* x y)))) (applyf (mul 2)))", + ";============================================", + ";CONSTANT FOLDING TEST CASES", + ";============================================", + + ";--- Addition with numbers and variables ---", + ";Pure constant folding", + "(+ 3 4)", + "(+ (+ 1 2) (+ 3 4))", + + ";Number + variable combinations", + "(+ 0 x)", + "(+ x 0)", + "(+ 5 (+ 3 x))", + "(+ 5 (+ x 3))", + "(+ (+ x 3) 5)", + "(+ (+ 3 x) 5)", + + ";Adding expressions with both + and -", + "(+ 2 (- 5 x))", + "(+ 2 (- x 5))", + "(+ (- 3 x) 4)", + "(+ (- x 3) 4)", + + ";Two compound expressions", + "(+ (+ 2 x) (+ 3 y))", + "(+ (+ x 2) (+ y 3))", + "(+ (+ 2 x) (- 3 y))", + "(+ (- 2 x) (- 3 y))", + "(+ (- x 2) (- y 3))", + "(+ (- x 2) (- 3 y))", + + ";--- Subtraction with numbers and variables ---", + "(- 10 3)", + "(- x 0)", + "(- 0 x)", + "(- 5 (+ 2 x))", + "(- 5 (+ x 2))", + "(- 5 (- 2 x))", + "(- 5 (- x 2))", + "(- (+ 5 x) 3)", + "(- (+ x 5) 3)", + "(- (- 5 x) 3)", + "(- (- x 5) 3)", + + ";Two compound sub expressions", + "(- (+ 5 x) (+ 2 y))", + "(- (- 5 x) (+ 2 y))", + "(- (+ 5 x) (- 2 y))", + "(- (+ 5 x) (- y 2))", + "(- (- 5 x) (- 2 y))", + "(- (- x 5) (- y 2))", + "(- (- 5 x) (- y 2))", + + ";--- Multiplication with numbers and variables ---", + "(* 3 4)", + "(* 0 x)", + "(* x 0)", + "(* 1 x)", + "(* x 1)", + "(* 2 (* 3 x))", + "(* 2 (* x 3))", + "(* (* x 2) 3)", + "(* (* 2 x) 3)", + + ";Multiplication distributing over addition/subtraction", + "(* 3 (+ x 4))", + "(* 3 (+ 4 x))", + "(* (+ x 4) 3)", + "(* 3 (- x 4))", + "(* 3 (- 4 x))", + "(* (- x 4) 3)", + "(* (- 4 x) 3)", + + ";Multiplication with division", + "(* 6 (/ 2 x))", + "(* 6 (/ x 2))", + "(* (/ x 2) 6)", + "(* (/ 2 x) 6)", + + ";--- Division with numbers and variables ---", + "(/ 12 4)", + "(/ x 1)", + "(/ 0 x)", + "(/ (/ x 2) 3)", + "(/ (/ 6 x) 2)", + "(/ 6 (/ 2 x))", + "(/ 6 (/ x 2))", + "(/ 6 (* x 2))", + "(/ 6 (* 2 x))", + "(/ (* 6 x) 2)", + "(/ (* x 6) 2)", + + ";Division distributing over numerator addition/subtraction", + "(/ (+ 6 x) 2)", + "(/ (+ x 6) 2)", + "(/ (- 6 x) 2)", + "(/ (- x 6) 2)", + + ";Compound division expressions", + "(* (/ x 2) (/ y 3))", + "(* (/ 2 x) (/ 3 y))", + "(/ (/ x 2) (/ y 3))", + "(/ (/ 2 x) (/ 3 y))", + + ";--- Power with numbers and variables ---", + "(** 2 3)", + "(** x 0)", + "(** x 1)", + "(** 0 x)", + "(** 1 x)", + "(** (** x 2) 3)", + "(* (** x 2) (** x 3))", + "(** (* x 2) 3)", + "(** (* 2 x) 3)", + + ";--- Mixed operations - deeper nesting ---", + "(+ 1 (+ 2 (+ 3 (+ 4 x))))", + "(+ 1 (+ 2 (+ 3 (+ 4 (+ 5 (+ 6 x))))))", + "(* 2 (* 3 (* 4 (* 5 x))))", + "(- 10 (- 9 (- 8 (- 7 (- 6 x)))))", + "(+ 1 (- 2 (+ 3 (- 4 (+ 5 x)))))", + "(* 2 (+ 3 (* 4 (+ 5 (* 6 x)))))", + "(/ (/ (/ (* 24 x) 2) 3) 4)", + "(** (** x 2) 3)", + "(* 2 (+ 3 (* 4 x)))", + "(+ (* 2 3) (* 4 x))", + "(- (* 2 (+ x 3)) 5)", + "(/ (+ (* 2 x) 6) 2)", + + ";--- Complex expressions with multiple variables ---", + "(+ (+ x 1) (+ y 2))", + "(+ (* 2 x) (* 3 y))", + "(- (* 2 (+ x 1)) (* 3 (- y 1)))", + "(/ (+ (* 2 x) 4) 2)", + + ";--- Expressions that should fully reduce to constants ---", + "(+ (+ 1 2) (+ 3 4))", + "(* (+ 2 3) (- 10 4))", + "(/ (* 3 4) (+ 1 1))", + "(** (+ 1 1) (- 5 2))", + "(+ 1 (+ 2 (+ 3 (+ 4 (+ 5 6)))))", + "(* 2 (* 3 (* 4 (* 5 1))))", + "(- 100 (- 50 (- 25 (- 10 5))))", + "(/ (* (+ 2 4) (- 8 2)) (** 2 2))", + "(+ (* 2 (+ 3 4)) (- (* 5 6) (/ 20 4)))", + + ";--- Edge cases ---", + "(+ (- x x) 5)", + "(* (/ x x) 5)", + "(+ x (- 0 x))", + "(* x (/ 1 x))", + + ";--- Nested with function calls (should partially fold) ---", + "(+ 3 (+ 4 (f x)))", + "(* 2 (+ 3 (f x)))", + "(+ (* 2 3) (f x))", + "(- (+ 5 (f x)) 3)", + "(/ (* 6 (f x)) 2)", + "(+ 1 (+ 2 (+ 3 (+ 4 (f x)))))", + "(* 2 (* 3 (* 4 (f x))))", + "(+ (* 2 (+ 3 4)) (f x))", + "(- (* 2 (+ 5 (f x))) 10)", + "(/ (* 6 (+ 2 (f x))) 3)", + "(+ (f x) (+ 1 (+ 2 (+ 3 4))))", + "(* (+ 2 3) (+ (f x) 10))", + + ";--- test eta reduction ---", + "(λ (x) (f x))", + "(λ (x) ((h p) x))", + "(λ (y) ((λ (x) (g x)) y))", + "(λ (y) ((λ (x) ((h p) x)) y))", + ]}; diff --git a/fn/rewrite/subst.fn b/fn/rewrite/subst.fn index d24fe5af..2710d817 100644 --- a/fn/rewrite/subst.fn +++ b/fn/rewrite/subst.fn @@ -1,188 +1,130 @@ namespace - link "expr.fn" as E; + link "minexpr.fn" as M; link "../dictutils.fn" as D; link "../listutils.fn" as list; - // substitute: D.Dict(string, E.expr) -> E.expr -> E.expr + // substitute: D.Dict(string, M.expr) -> M.expr -> M.expr fn substitute(c, e) { if (D.is_empty(c)) { e } else { switch (e) { // amb_expr(expr, expr) - (E.amb_expr(expr1, expr2)) { - E.amb_expr(substitute(c, expr1), substitute(c, expr2)) + (M.amb_expr(expr1, expr2)) { + M.amb_expr(substitute(c, expr1), substitute(c, expr2)) } // apply_closure(expr, list(expr)) - (E.apply_closure(f, args)) { - E.apply_closure(substitute(c, f), list.map(substitute(c), args)) + (M.apply_closure(f, args)) { + M.apply_closure(substitute(c, f), list.map(substitute(c), args)) } // apply(expr, list(expr)) - (E.apply(fun, args)) { - E.apply(substitute(c, fun), list.map(substitute(c), args)) - } - - (x = E.back_expr) | - (x = E.env_expr) | - (x = E.error_expr) | - (x = E.bigint(_)) | - (x = E.character(_)) | - (x = E.constructor_info(_)) | - (x = E.stdint(_)) | - (x = E.constant(_)) { + (M.apply(fun, args)) { + M.apply(substitute(c, fun), list.map(substitute(c), args)) + } + + (x = M.back_expr) | + (x = M.primop(_)) | + (x = M.env_expr) | + (x = M.error_expr) | + (x = M.bigint(_)) | + (x = M.character(_)) | + (x = M.stdint(_)) { x } // callcc_expr(expr) - (E.callcc_expr(e)) { - E.callcc_expr(substitute(c, e)) + (M.callcc_expr(e)) { + M.callcc_expr(substitute(c, e)) } // cond_expr(expr, list(#(expr, expr))) - (E.cond_expr(test, branches)) { + (M.cond_expr(test, branches)) { let #(vals, results) = list.unzip(branches); - in E.cond_expr(substitute(c, test), + in M.cond_expr(substitute(c, test), list.zip(list.map(substitute(c), vals), list.map(substitute(c), results))) } - // construct(string, list(expr)) - (E.construct(name, args)) { - E.construct(name, list.map(substitute(c), args)) - } - - // deconstruct(string, number, expr) - (E.deconstruct(name, index, expr)) { - E.deconstruct(name, index, substitute(c, expr)) - } - // if_expr(expr, expr, expr) - (E.if_expr(exprc, exprt, exprf)) { - E.if_expr(substitute(c, exprc), + (M.if_expr(exprc, exprt, exprf)) { + M.if_expr(substitute(c, exprc), substitute(c, exprt), substitute(c, exprf)) } // lambda(list(string), expr) - (E.lambda(params, body)) { + (M.lambda(params, body)) { let c2 = D.delete_list(params, c); - in E.lambda(params, substitute(c2, body)) + in M.lambda(params, substitute(c2, body)) } // lambda(list(string), expr) - (E.lambdac(params, body)) { + (M.lambdac(params, body)) { let c2 = D.delete_list(params, c); - in E.lambdac(params, substitute(c2, body)) + in M.lambdac(params, substitute(c2, body)) } // make_closure(expr, env) - (E.make_closure(body, env)) { - E.make_closure(substitute(c, body), substitute(c, env)) + (M.make_closure(body, env)) { + M.make_closure(substitute(c, body), substitute(c, env)) } // make_env(list(#(string, expr))) - (E.make_env(bindings)) { - E.make_env(list.map(fn (#(v, e)) { #(v, substitute(c, e)) }, bindings)) + (M.make_env(bindings)) { + M.make_env(list.map(fn (#(v, e)) { #(v, substitute(c, e)) }, bindings)) } // env_ref(expr, string) - (E.env_ref(e, s)) { - E.env_ref(substitute(c, e), s) + (M.env_ref(e, s)) { + M.env_ref(substitute(c, e), s) } // letrec_expr(list(#(string, expr)), expr) - (E.letrec_expr(bindings, expr)) { + (M.letrec_expr(bindings, expr)) { let c2 = D.delete_list(list.map(fn (#(var, val)) { var }, bindings), c); - in E.letrec_expr(bindings, substitute(c2, expr)) // new environment - } - - // let_expr(list(#(string, expr)), expr) - (E.let_expr(bindings, expr)) { - let c2 = D.delete_list(list.map(fn (#(var, val)) { var }, bindings), c); - in E.let_expr(bindings, substitute(c2, expr)) - } - - // letstar_expr(list(#(string, expr)), expr) - (E.letstar_expr(bindings, expr)) { - let c2 = D.delete_list(list.map(fn (#(var, val)) { var }, bindings), c); - in E.letstar_expr(bindings, substitute(c2, expr)) + in M.letrec_expr(bindings, substitute(c2, expr)) // new environment } // lookup(string, number, expr) - (E.lookup(name, index, expr)) { + (M.lookup(name, index, expr)) { e } - // make_tuple(list(expr)) - (E.make_tuple(args)) { - E.make_tuple(list.map(substitute(c), args)) - } - // make_vec(number, list(expr)) - (E.make_vec(size, args)) { - E.make_vec(size, list.map(substitute(c), args)) + (M.make_vec(size, args)) { + M.make_vec(size, list.map(substitute(c), args)) } // match_cases(expr, list(#(list(number), expr))) - (E.match_cases(test, cases)) { + (M.match_cases(test, cases)) { let #(vals, results) = list.unzip(cases); in - E.match_cases(substitute(c, test), + M.match_cases(substitute(c, test), list.zip(vals, list.map(substitute(c), results))) } // namespaces(list(expr)) - (E.namespaces(exprs)) { - E.namespaces(list.map(substitute(c), exprs)) - } - - // primapp(string, expr, expr) - (E.primapp(p, e1, e2)) { - E.primapp(p, substitute(c, e1), substitute(c, e2)) - } - - // print_exp(expr) - (E.print_exp(expr)) { - E.print_exp(substitute(c, expr)) + (M.namespaces(exprs)) { + M.namespaces(list.map(substitute(c), exprs)) } // sequence(list(expr)) - (E.sequence(exprs)) { - E.sequence(list.map(substitute(c), exprs)) - } - - // tag(expr) - (E.tag(expr)) { - E.tag(substitute(c, expr)) - } - - // tuple_index(number, number, expr) - (E.tuple_index(size, index, expr)) { - E.tuple_index(size, index, substitute(c, expr)) - } - - // typedefs(list(def), expr) - (E.typedefs(defs, expr)) { - E.typedefs(defs, substitute(c, expr)) - } - - // typeof_expr(expr) - (E.typeof_expr(expr)) { - E.typeof_expr(substitute(c, expr)) + (M.sequence(exprs)) { + M.sequence(list.map(substitute(c), exprs)) } // var(string) - (E.var(name)) { + (M.var(name)) { switch (D.lookup(name, c)) { (nothing) { e } - (some(v)) { v } + (just(v)) { v } } } (x) { - E.print_expr(x); + M.print_expr(x); puts("\n"); error("substitute: unsupported expression") } diff --git a/fn/rewrite/test_harness.fn b/fn/rewrite/test_harness.fn index d13a68e4..7f13b287 100644 --- a/fn/rewrite/test_harness.fn +++ b/fn/rewrite/test_harness.fn @@ -1,23 +1,57 @@ let link "samples.fn" as Samples; + link "beta_reduce.fn" as β; + link "eta_reduce.fn" as η; + link "constant_folding.fn" as OF; link "expr.fn" as E; + link "minexpr.fn" as M; link "../listutils.fn" as list; link "desugar.fn" as DS; link "cps.fn" as CPS; + // link "normalize.fn" as N; link "closure-convert.fn" as CC; + link "curry.fn" as C; in - list.for_each(fn (str) { - let - expr = E.parse(str); - dexpr = DS.desugar(expr); - cexpr = CPS.T_c(dexpr, E.var("□")); - tab = "\n "; - in - E.print_expr(expr); - puts(" ==>"); - puts(tab); - E.print_expr(CC.shared_closure_convert(cexpr)); - puts(tab); - E.print_expr(CC.flat_closure_convert(cexpr)); - puts("\n\n") - }, Samples.data); \ No newline at end of file + list.for_each(fn { + (';' @ s) { + // print comments + puts("; "); + puts(s); + puts("\n"); + } + (str) { + let + a = E.parse(str); + b = DS.desugar(a); + c = C.curry(b); + d = η.reduce(c); + e = CPS.T_c(d, M.var("□")); + f = β.reduce(e); + g = OF.fold(f); + h = CC.shared_closure_convert(g); + nltab = "\n "; + in + E.print_expr(a); + // puts("\n==> desugar"); + // puts(nltab); + // M.print_expr(b); + // puts("\n==> eta reduce"); + // puts(nltab); + // M.print_expr(d); + // puts("\n==> cps transform"); + // puts(nltab); + // M.print_expr(e); + // puts("\n==> beta reduce"); + // puts(nltab); + // M.print_expr(f); + // puts("\n==> operator folding"); + // puts(nltab); + puts("\n "); + M.print_expr(g); + // puts("\n==> shared closure convert"); + // puts(nltab); + // M.print_expr(h); + // puts("\n\n\n") + puts("\n\n") + } + }, Samples.data()); \ No newline at end of file diff --git a/fn/rewrite/transform.fn b/fn/rewrite/transform.fn index 453b1bd8..3f567a03 100644 --- a/fn/rewrite/transform.fn +++ b/fn/rewrite/transform.fn @@ -1,174 +1,119 @@ namespace -link "expr.fn" as E; +link "minexpr.fn" as M; link "../listutils.fn" as list; -// (E.expr -> E.expr) -> E.expr -> E.expr +// (M.expr -> M.expr) -> M.expr -> M.expr fn bottom_up(f, exp) { f(_transform(bottom_up(f), exp)) } -// (E.expr -> E.expr) -> E.expr -> E.expr +// (M.expr -> M.expr) -> M.expr -> M.expr fn top_down(f, exp) { _transform(top_down(f), f(exp)) } -// (E.expr -> E.expr) -> E.expr -> E.expr +// (M.expr -> M.expr) -> M.expr -> M.expr fn _transform(t, exp) { switch (exp) { // amb_expr(expr, expr) - (E.amb_expr(e1, e2)) { - E.amb_expr(t(e1), t(e2)) - } - - // back_expr - (E.back_expr) | - // character(char) - (E.character(_)) | - // constant(string) - (E.constant(_)) | - // constructor_info(string) - (E.constructor_info(_)) | - // env_expr - (E.env_expr) | - // error_expr - (E.error_expr) | - // stdint(number) - (E.stdint(_)) | - // var(string) - (E.var(_)) | - // bigint(number) - (E.bigint(_)) { exp } + (M.amb_expr(e1, e2)) { + M.amb_expr(t(e1), t(e2)) + } + + (M.back_expr) | + (M.primop(_)) | + (M.character(_)) | + (M.env_expr) | + (M.error_expr) | + (M.stdint(_)) | + (M.var(_)) | + (M.bigint(_)) { exp } // apply_closure(expr, list(expr)) - (E.apply_closure(fun, args)) { - E.apply_closure(t(fun), list.map(t, args)) + (M.apply_closure(fun, args)) { + M.apply_closure(t(fun), list.map(t, args)) } // apply(expr, list(expr)) - (E.apply(fun, args)) { - E.apply(t(fun), list.map(t, args)) + (M.apply(fun, args)) { + M.apply(t(fun), list.map(t, args)) } // callcc_expr(expr) - (E.callcc_expr(e)) { - E.callcc_expr(t(e)) + (M.callcc_expr(e)) { + M.callcc_expr(t(e)) } // cond_expr(expr, list(#(expr, expr))) - (E.cond_expr(test, branches)) { - E.cond_expr(t(test), list.map(fn (#(cond, res)) { #(t(cond), t(res)) }, branches)) - } - - // construct(string, list(expr)) - (E.construct(tag, fields)) { - E.construct(tag, list.map(t, fields)) - } - - // deconstruct(string, number, expr) - (E.deconstruct(tag, n, e)) { - E.deconstruct(tag, n, t(e)) + (M.cond_expr(test, branches)) { + M.cond_expr(t(test), list.map(fn (#(cond, res)) { #(t(cond), t(res)) }, branches)) } // env_ref(expr, string) - (E.env_ref(e, s)) { - E.env_ref(t(e), s) + (M.env_ref(e, s)) { + M.env_ref(t(e), s) } // if_expr(expr, expr, expr) - (E.if_expr(cond, then_branch, else_branch)) { - E.if_expr(t(cond), t(then_branch), t(else_branch)) + (M.if_expr(cond, then_branch, else_branch)) { + M.if_expr(t(cond), t(then_branch), t(else_branch)) } // lambda(list(string), expr) - (E.lambda(params, body)) { - E.lambda(params, t(body)) + (M.lambda(params, body)) { + M.lambda(params, t(body)) } // lambdac(list(string), expr) - (E.lambdac(params, body)) { - E.lambdac(params, t(body)) + (M.lambdac(params, body)) { + M.lambdac(params, t(body)) } // letrec_expr(list(#(string, expr)), expr) - (E.letrec_expr(bindings, body)) { - E.letrec_expr(list.map(fn (#(v, e)) { #(v, t(e)) }, bindings), t(body)) + (M.letrec_expr(bindings, body)) { + M.letrec_expr(list.map(fn (#(v, e)) { #(v, t(e)) }, bindings), t(body)) } // lookup(string, number, expr) - (E.lookup(s, n, e)) { - E.lookup(s, n, t(e)) + (M.lookup(s, n, e)) { + M.lookup(s, n, t(e)) } // make_closure(expr, expr) - (E.make_closure(lam, env)) { - E.make_closure(t(lam), t(env)) + (M.make_closure(lam, env)) { + M.make_closure(t(lam), t(env)) } // make_env(list(#(string, expr))) - (E.make_env(bindings)) { - E.make_env(list.map(fn (#(v, e)) { #(v, t(e)) }, bindings)) - } - - // make_tuple(list(expr)) - (E.make_tuple(elements)) { - E.make_tuple(list.map(t, elements)) + (M.make_env(bindings)) { + M.make_env(list.map(fn (#(v, e)) { #(v, t(e)) }, bindings)) } // make_vec(number, list(expr)) - (E.make_vec(size, elements)) { - E.make_vec(size, list.map(t, elements)) + (M.make_vec(size, elements)) { + M.make_vec(size, list.map(t, elements)) } // match_cases(expr, list(#(list(number), expr))) - (E.match_cases(e, cases)) { - E.match_cases(t(e), list.map(fn (#(indices, res)) { #(indices, t(res)) }, cases)) + (M.match_cases(e, cases)) { + M.match_cases(t(e), list.map(fn (#(indices, res)) { #(indices, t(res)) }, cases)) } // namespaces(list(expr)) - (E.namespaces(exprs)) { - E.namespaces(list.map(t, exprs)) - } - - // primapp(string, expr, expr) - (E.primapp(op, e1, e2)) { - E.primapp(op, t(e1), t(e2)) - } - - // print_exp(expr) - (E.print_exp(e)) { - E.print_exp(t(e)) + (M.namespaces(exprs)) { + M.namespaces(list.map(t, exprs)) } // sequence(list(expr)) - (E.sequence(exps)) { - E.sequence(list.map(t, exps)) - } - - // tag(expr) - (E.tag(e)) { - E.tag(t(e)) - } - - // tuple_index(number, number, expr) - (E.tuple_index(i, j, e)) { - E.tuple_index(i, j, t(e)) - } - - // typedefs(number, expr) - (E.typedefs(n, e)) { - E.typedefs(n, t(e)) - } - - // typeof_expr(expr) - (E.typeof_expr(e)) { - E.typeof_expr(t(e)) + (M.sequence(exps)) { + M.sequence(list.map(t, exps)) } (_) { - E.print_expr(exp); + M.print_expr(exp); puts(": "); error("Unhandled expression type in transform") } diff --git a/fn/sqliteutils.fn b/fn/sqliteutils.fn index 599fab88..9cfb80e1 100644 --- a/fn/sqliteutils.fn +++ b/fn/sqliteutils.fn @@ -52,7 +52,7 @@ fn with_results(handler, statement) { let fn _with_results(keys) { switch(sqlite3_fetch(statement)) { - (some(row)) { + (just(row)) { handler(dict.make(keys, row)); _with_results(keys) } diff --git a/fn/ternary.fn b/fn/ternary.fn index c5bc7d57..dc88348e 100644 --- a/fn/ternary.fn +++ b/fn/ternary.fn @@ -1,5 +1,5 @@ let - macro TEST(lhs, rhs) { fn { (true) { lhs } (false) { rhs } } } + lazy fn TEST(lhs, rhs) { fn { (true) { lhs } (false) { rhs } } } operator "_?_" right 2 fn (tst, swtch) { swtch(tst) }; operator "_:_" left 2 TEST; in diff --git a/fn/test_ls.fn b/fn/test_ls.fn index 8bc7b24c..14999547 100644 --- a/fn/test_ls.fn +++ b/fn/test_ls.fn @@ -2,7 +2,7 @@ let fn ls(dir) { let fn helper { - (some(name), dh) { + (just(name), dh) { let path = dir @@ "/" @@ name; in @@ -29,6 +29,6 @@ let } in ls(switch (argv(0)) { - (some(name)) { name } + (just(name)) { name } (nothing) { "." } }) diff --git a/scratch/README.md b/scratch/README.md new file mode 100644 index 00000000..eb9f8112 --- /dev/null +++ b/scratch/README.md @@ -0,0 +1,3 @@ +# Scratch Folder + +This is just a place to run random experiments. diff --git a/src/anf.yaml b/src/anf.yaml index c1a81cd4..e8fce059 100644 --- a/src/anf.yaml +++ b/src/anf.yaml @@ -20,6 +20,8 @@ config: name: anf description: A-Normal Form (ANF) structures to be converted to bytecode. parserInfo: true + includes: + - utils.h limited_includes: - bigint.h - ast_helper.h @@ -35,9 +37,10 @@ structs: data: isLocal: bool isNameSpace: bool = false + isCapturing: bool = false nBindings: int = 0 nsEnvs: AnfEnvArray = NULL - table: AnfIntTable + table: IntMap next: AnfEnv AexpLam: @@ -310,20 +313,6 @@ enums: - MOD - CMP -hashes: - AnfSymbolTable: - meta: - brief: A set of ANF Symbols - description: A hash table set of symbols used in ANF. - data: {} - - AnfIntTable: - meta: - brief: ANF Compile Time Integer Table - description: A hash table of integers used in ANF. - data: - entries: int - arrays: AexpNameSpaceArray: meta: @@ -342,12 +331,5 @@ arrays: primitives: !include primitives.yaml external: - TcType: - meta: - brief: external type from the type-checker - description: A type-checker type referenced by the ANF code. - data: - cname: "struct TcType *" - printFn: printTcType - markFn: markTcType - valued: true +- !include utils.yaml +- !include tc.yaml \ No newline at end of file diff --git a/src/anf_normalize.c b/src/anf_normalize.c index 83dcc774..c47bd740 100644 --- a/src/anf_normalize.c +++ b/src/anf_normalize.c @@ -17,177 +17,142 @@ */ #include "anf_normalize.h" +#include "bigint.h" #include "common.h" #include "hash.h" -#include "symbol.h" #include "memory.h" -#include "lambda_helper.h" -#include "bigint.h" +#include "minlam_helper.h" +#include "symbol.h" #ifdef DEBUG_ANF -# include -# include -# include "debug.h" -# include "lambda_pp.h" -# include "anf_debug.h" -# include "debugging_on.h" +#include "anf_debug.h" +#include "debug.h" +#include "debugging_on.h" +#include "minlam_pp.h" +#include +#include #else -# include "debugging_off.h" +#include "debugging_off.h" #endif -static AnfExp *normalize(LamExp *lamExp, AnfExp *tail); -static AnfExp *normalizeLam(LamLam *lamLam, AnfExp *tail); -static AnfExp *normalizeNameSpaces(ParserInfo I, LamNameSpaceArray *nsArray, AnfExp *tail); +static AnfExp *normalize(MinExp *minExp, AnfExp *tail); +static AnfExp *normalizeMin(MinLam *minMin, AnfExp *tail); +static AnfExp *normalizeNameSpaces(ParserInfo I, MinNameSpaceArray *nsArray, + AnfExp *tail); static AnfExp *normalizeVar(ParserInfo I, HashSymbol *var, AnfExp *tail); -static AnfExp *normalizeMaybeBigInteger(ParserInfo I, MaybeBigInt *integer, AnfExp *tail); +static AnfExp *normalizeMaybeBigInteger(ParserInfo I, MaybeBigInt *integer, + AnfExp *tail); static AnfExp *normalizeStdInteger(ParserInfo I, int integer, AnfExp *tail); -static AnfExp *normalizeCharacter(ParserInfo I, Character character, AnfExp *tail); -static AnfExp *normalizeAmb(LamAmb *app, AnfExp *tail); -static AnfExp *normalizeSequence(LamSequence *sequence, AnfExp *tail); -static AnfExp *normalizePrim(LamPrimApp *app, AnfExp *tail); -static AnfExp *normalizeApply(LamApply *lamApply, AnfExp *tail); +static AnfExp *normalizeCharacter(ParserInfo I, Character character, + AnfExp *tail); +static AnfExp *normalizeAmb(MinAmb *app, AnfExp *tail); +static AnfExp *normalizeSequence(MinExprList *sequence, AnfExp *tail); +static AnfExp *normalizePrim(MinPrimApp *app, AnfExp *tail); +static AnfExp *normalizeApply(MinApply *minApply, AnfExp *tail); static AnfExp *normalizeBack(ParserInfo I, AnfExp *tail); static AnfExp *normalizeError(ParserInfo I, AnfExp *tail); static HashSymbol *freshSymbol(); -static LamExpTable *makeLamExpHashTable(); -static Aexp *replaceLamExp(LamExp *lamExp, LamExpTable *replacements); -static AnfExp *letBind(AnfExp *body, LamExpTable *replacements); -static AexpPrimOp mapPrimOp(LamPrimOp op); +static Aexp *replaceMinExp(MinExp *minExp, MinExpTable *replacements); +static AnfExp *letBind(AnfExp *body, MinExpTable *replacements); +static AexpPrimOp mapPrimOp(MinPrimOp op); static Aexp *aexpNormalizeVar(ParserInfo I, HashSymbol *var); static Aexp *aexpNormalizeMaybeBigInteger(ParserInfo I, MaybeBigInt *integer); static Aexp *aexpNormalizeStdInteger(ParserInfo I, int integer); static Aexp *aexpNormalizeCharacter(ParserInfo I, Character character); -static Aexp *aexpNormalizeLam(LamLam *lamLam); -static AexpNameSpaceArray *aexpNormalizeNameSpaces(ParserInfo I, LamNameSpaceArray *nsArray); -static AexpVarList *convertVarList(LamVarList *args); -static AexpList *replaceLamArgs(LamArgs *, LamExpTable *); -static Aexp *replaceLamPrim(LamPrimApp *lamPrimApp, - LamExpTable *replacements); -static Aexp *replaceLamMakeVec(LamMakeVec *makeVec, - LamExpTable *replacements); -static Aexp *replaceLamConstruct(LamConstruct *construct, - LamExpTable *replacements); -static Aexp *replaceLamPrint(LamPrint *print, LamExpTable *replacements); -static Aexp *replaceLamCexp(LamExp *apply, LamExpTable *replacements); -static AnfExp *normalizeMakeVec(LamMakeVec *makeVec, AnfExp *tail); +static Aexp *aexpNormalizeLam(MinLam *minMin); +static AexpNameSpaceArray *aexpNormalizeNameSpaces(ParserInfo I, + MinNameSpaceArray *nsArray); +static AexpVarList *convertVarList(SymbolList *args); +static AexpList *replaceMinArgs(MinExprList *, MinExpTable *); +static Aexp *replaceMinPrim(MinPrimApp *minPrimApp, MinExpTable *replacements); +static Aexp *replaceMinMakeVec(MinExprList *makeVec, MinExpTable *replacements); +static Aexp *replaceMinCexp(MinExp *apply, MinExpTable *replacements); +static AnfExp *normalizeMakeVec(ParserInfo PI, MinExprList *makeVec, + AnfExp *tail); static AnfExp *wrapTail(AnfExp *exp, AnfExp *tail); -static AnfExp *normalizeIff(LamIff *lamIff, AnfExp *tail); -static AnfExp *normalizeCallCc(LamExp *callCC, AnfExp *tail); -static AnfExp *normalizePrint(LamPrint *print, AnfExp *tail); -static AnfExp *normalizeLetRec(LamLetRec *lamLetRec, AnfExp *tail); -static AnfExp *normalizeLet(LamLet *lamLet, AnfExp *tail); -static AnfExp *normalizeLetStar(LamLetStar *, AnfExp *); -static AnfExp *normalizeMatch(LamMatch *match, AnfExp *tail); -static AnfMatchList *normalizeMatchList(LamMatchList *matchList); -static AexpIntList *convertIntList(LamIntList *list); -static AnfExp *normalizeCond(LamCond *cond, AnfExp *tail); -static CexpCondCases *normalizeCondCases(LamCondCases *cases); -static CexpLetRec *normalizeLetRecBindings(CexpLetRec *, LamBindings *); -static AnfExp *normalizeConstruct(LamConstruct *construct, AnfExp *tail); -static AnfExp *normalizeMakeTuple(ParserInfo, LamArgs *, AnfExp *); -static AnfExp *normalizeTupleIndex(LamTupleIndex *construct, AnfExp *tail); -static AnfExp *normalizeDeconstruct(LamDeconstruct *deconstruct, AnfExp *tail); -static AnfExp *normalizeTag(LamExp *tag, AnfExp *tail); +static AnfExp *normalizeIff(MinIff *minIff, AnfExp *tail); +static AnfExp *normalizeCallCc(MinExp *callCC, AnfExp *tail); +static AnfExp *normalizeLetRec(MinLetRec *minLetRec, AnfExp *tail); +static AnfExp *normalizeMatch(MinMatch *match, AnfExp *tail); +static AnfMatchList *normalizeMatchList(MinMatchList *matchList); +static AexpIntList *convertIntList(MinIntList *list); +static AnfExp *normalizeCond(MinCond *cond, AnfExp *tail); +static CexpCondCases *normalizeCondCases(MinCondCases *cases); +static CexpLetRec *normalizeLetRecBindings(CexpLetRec *, MinBindings *); static AnfExp *normalizeEnv(ParserInfo I, AnfExp *tail); -static AnfExp *normalizeLamLookUp(LamLookUp *, AnfExp *); +static AnfExp *normalizeMinLookUp(MinLookUp *, AnfExp *); -AnfExp *anfNormalize(LamExp *lamExp) { - return normalize(lamExp, NULL); -} +AnfExp *anfNormalize(MinExp *minExp) { return normalize(minExp, NULL); } -static AnfExp *normalize(LamExp *lamExp, AnfExp *tail) { - if (lamExp == NULL) { +static AnfExp *normalize(MinExp *minExp, AnfExp *tail) { + if (minExp == NULL) { return NULL; } ENTER(normalize); - IFDEBUG(ppLamExp(lamExp)); - switch (lamExp->type) { - case LAMEXP_TYPE_LAM: - return normalizeLam(getLamExp_Lam(lamExp), tail); - case LAMEXP_TYPE_VAR: - return normalizeVar(CPI(lamExp), getLamExp_Var(lamExp), tail); - case LAMEXP_TYPE_STDINT: - return normalizeStdInteger(CPI(lamExp), getLamExp_Stdint(lamExp), tail); - case LAMEXP_TYPE_BIGINTEGER: - return normalizeMaybeBigInteger(CPI(lamExp), getLamExp_BigInteger(lamExp), tail); - case LAMEXP_TYPE_PRIM: - return normalizePrim(getLamExp_Prim(lamExp), tail); - case LAMEXP_TYPE_AMB: - return normalizeAmb(getLamExp_Amb(lamExp), tail); - case LAMEXP_TYPE_SEQUENCE: - return normalizeSequence(getLamExp_Sequence(lamExp), tail); - case LAMEXP_TYPE_MAKEVEC: - return normalizeMakeVec(getLamExp_MakeVec(lamExp), tail); - case LAMEXP_TYPE_TYPEDEFS: - return normalize(getLamExp_TypeDefs(lamExp)->body, tail); - case LAMEXP_TYPE_APPLY: - return normalizeApply(getLamExp_Apply(lamExp), tail); - case LAMEXP_TYPE_IFF: - return normalizeIff(getLamExp_Iff(lamExp), tail); - case LAMEXP_TYPE_CALLCC: - return normalizeCallCc(getLamExp_CallCC(lamExp), tail); - case LAMEXP_TYPE_PRINT: - return normalizePrint(getLamExp_Print(lamExp), tail); - case LAMEXP_TYPE_LET: - return normalizeLet(getLamExp_Let(lamExp), tail); - case LAMEXP_TYPE_LETSTAR: - return normalizeLetStar(getLamExp_LetStar(lamExp), tail); - case LAMEXP_TYPE_LETREC: - return normalizeLetRec(getLamExp_LetRec(lamExp), tail); - case LAMEXP_TYPE_TUPLEINDEX: - return normalizeTupleIndex(getLamExp_TupleIndex(lamExp), tail); - case LAMEXP_TYPE_DECONSTRUCT: - return normalizeDeconstruct(getLamExp_Deconstruct(lamExp), tail); - case LAMEXP_TYPE_CONSTRUCT: - return normalizeConstruct(getLamExp_Construct(lamExp), tail); - case LAMEXP_TYPE_TAG: - return normalizeTag(getLamExp_Tag(lamExp), tail); - case LAMEXP_TYPE_CONSTANT: - return normalizeStdInteger(CPI(lamExp), getLamExp_Constant(lamExp)->tag, tail); - case LAMEXP_TYPE_MATCH: - return normalizeMatch(getLamExp_Match(lamExp), tail); - case LAMEXP_TYPE_COND: - return normalizeCond(getLamExp_Cond(lamExp), tail); - case LAMEXP_TYPE_CHARACTER: - return normalizeCharacter(CPI(lamExp), getLamExp_Character(lamExp), tail); - case LAMEXP_TYPE_BACK: - return normalizeBack(CPI(lamExp), tail); - case LAMEXP_TYPE_ERROR: - return normalizeError(CPI(lamExp), tail); - case LAMEXP_TYPE_MAKETUPLE: - return normalizeMakeTuple(CPI(lamExp), getLamExp_MakeTuple(lamExp), tail); - case LAMEXP_TYPE_NAMESPACES: - return normalizeNameSpaces(CPI(lamExp), getLamExp_NameSpaces(lamExp), tail); - case LAMEXP_TYPE_ENV: - return normalizeEnv(CPI(lamExp), tail); - case LAMEXP_TYPE_LOOKUP: - return normalizeLamLookUp(getLamExp_LookUp(lamExp), tail); - default: - cant_happen("unrecognized type %s", lamExpTypeName(lamExp->type)); + IFDEBUG(ppMinExp(minExp)); + switch (minExp->type) { + case MINEXP_TYPE_LAM: + return normalizeMin(getMinExp_Lam(minExp), tail); + case MINEXP_TYPE_VAR: + return normalizeVar(CPI(minExp), getMinExp_Var(minExp), tail); + case MINEXP_TYPE_STDINT: + return normalizeStdInteger(CPI(minExp), getMinExp_Stdint(minExp), tail); + case MINEXP_TYPE_BIGINTEGER: + return normalizeMaybeBigInteger(CPI(minExp), + getMinExp_BigInteger(minExp), tail); + case MINEXP_TYPE_PRIM: + return normalizePrim(getMinExp_Prim(minExp), tail); + case MINEXP_TYPE_AMB: + return normalizeAmb(getMinExp_Amb(minExp), tail); + case MINEXP_TYPE_SEQUENCE: + return normalizeSequence(getMinExp_Sequence(minExp), tail); + case MINEXP_TYPE_MAKEVEC: + return normalizeMakeVec(CPI(minExp), getMinExp_MakeVec(minExp), tail); + case MINEXP_TYPE_APPLY: + return normalizeApply(getMinExp_Apply(minExp), tail); + case MINEXP_TYPE_IFF: + return normalizeIff(getMinExp_Iff(minExp), tail); + case MINEXP_TYPE_CALLCC: + return normalizeCallCc(getMinExp_CallCC(minExp), tail); + case MINEXP_TYPE_LETREC: + return normalizeLetRec(getMinExp_LetRec(minExp), tail); + case MINEXP_TYPE_MATCH: + return normalizeMatch(getMinExp_Match(minExp), tail); + case MINEXP_TYPE_COND: + return normalizeCond(getMinExp_Cond(minExp), tail); + case MINEXP_TYPE_CHARACTER: + return normalizeCharacter(CPI(minExp), getMinExp_Character(minExp), + tail); + case MINEXP_TYPE_BACK: + return normalizeBack(CPI(minExp), tail); + case MINEXP_TYPE_ERROR: + return normalizeError(CPI(minExp), tail); + case MINEXP_TYPE_NAMESPACES: + return normalizeNameSpaces(CPI(minExp), getMinExp_NameSpaces(minExp), + tail); + case MINEXP_TYPE_ENV: + return normalizeEnv(CPI(minExp), tail); + case MINEXP_TYPE_LOOKUP: + return normalizeMinLookUp(getMinExp_LookUp(minExp), tail); + default: + cant_happen("unrecognized type %s", minExpTypeName(minExp->type)); } LEAVE(normalize); } -static AnfExp *wrapAexp(Aexp *aexp) { - return newAnfExp_Aexp(CPI(aexp), aexp); -} +static AnfExp *wrapAexp(Aexp *aexp) { return newAnfExp_Aexp(CPI(aexp), aexp); } -static AnfExp *wrapCexp(Cexp *cexp) { - return newAnfExp_Cexp(CPI(cexp), cexp); -} +static AnfExp *wrapCexp(Cexp *cexp) { return newAnfExp_Cexp(CPI(cexp), cexp); } -static AnfExp *normalizeCond(LamCond *cond, AnfExp *tail) { +static AnfExp *normalizeCond(MinCond *cond, AnfExp *tail) { ENTER(normalizeCond); - LamExpTable *replacements = makeLamExpHashTable(); + MinExpTable *replacements = newMinExpTable(); int save = PROTECT(replacements); - Aexp *value = replaceLamExp(cond->value, replacements); + Aexp *value = replaceMinExp(cond->value, replacements); int save2 = PROTECT(value); CexpCondCases *cases = normalizeCondCases(cond->cases); PROTECT(cases); - CexpCond *cexpCond = newCexpCond(CPI(value), value, cases); - UNPROTECT(save2); - save2 = PROTECT(cexpCond); - Cexp *cexp = newCexp_Cond(CPI(cexpCond), cexpCond); + Cexp *cexp = makeCexp_Cond(CPI(value), value, cases); REPLACE_PROTECT(save2, cexp); AnfExp *exp = wrapCexp(cexp); REPLACE_PROTECT(save2, exp); @@ -199,18 +164,15 @@ static AnfExp *normalizeCond(LamCond *cond, AnfExp *tail) { return exp; } -static AnfExp *normalizeMatch(LamMatch *match, AnfExp *tail) { +static AnfExp *normalizeMatch(MinMatch *match, AnfExp *tail) { ENTER(normalizeMatch); - LamExpTable *replacements = makeLamExpHashTable(); + MinExpTable *replacements = newMinExpTable(); int save = PROTECT(replacements); - Aexp *index = replaceLamExp(match->index, replacements); - int save2 = PROTECT(index); + Aexp *index = replaceMinExp(match->index, replacements); + PROTECT(index); AnfMatchList *matchList = normalizeMatchList(match->cases); - PROTECT(matchList); - CexpMatch *cexpMatch = newCexpMatch(CPI(index), index, matchList); - UNPROTECT(save2); - save2 = PROTECT(cexpMatch); - Cexp *cexp = newCexp_Match(CPI(cexpMatch), cexpMatch); + int save2 = PROTECT(matchList); + Cexp *cexp = makeCexp_Match(CPI(index), index, matchList); REPLACE_PROTECT(save2, cexp); AnfExp *exp = wrapCexp(cexp); REPLACE_PROTECT(save2, exp); @@ -222,7 +184,7 @@ static AnfExp *normalizeMatch(LamMatch *match, AnfExp *tail) { return res; } -static AnfMatchList *normalizeMatchList(LamMatchList *matchList) { +static AnfMatchList *normalizeMatchList(MinMatchList *matchList) { ENTER(normalizeMatchList); if (matchList == NULL) { LEAVE(normalizeMatchList); @@ -240,127 +202,14 @@ static AnfMatchList *normalizeMatchList(LamMatchList *matchList) { return this; } -static AnfExp *normalizeLetBindings(LamBindings *bindings, AnfExp *body) { - ENTER(normalizeLetBindings); - if (bindings == NULL) { - LEAVE(normalizeLetBindings); - return body; - } - AnfExp *tail = normalizeLetBindings(bindings->next, body); - int save = PROTECT(tail); - AnfExp *value = normalize(bindings->val, NULL); - PROTECT(value); - AnfExpLet *expLet = newAnfExpLet(CPI(bindings), bindings->var, value, tail); - PROTECT(expLet); - AnfExp *exp = newAnfExp_Let(CPI(expLet), expLet); - UNPROTECT(save); - LEAVE(normalizeLetBindings); - return exp; -} - -static AnfExp *normalizeLetStarBindings(LamBindings *bindings, AnfExp *body) { - ENTER(normalizeLetStarBindings); - if (bindings == NULL) { - LEAVE(normalizeLetStarBindings); - return body; - } - AnfExp *tail = normalizeLetStarBindings(bindings->next, body); - int save = PROTECT(tail); - AnfExp *value = normalize(bindings->val, NULL); - PROTECT(value); - AnfExp *exp = makeAnfExp_Let(CPI(bindings), bindings->var, value, tail); - UNPROTECT(save); - LEAVE(normalizeLetStarBindings); - return exp; -} - -static AnfExp *normalizeLet(LamLet *lamLet, AnfExp *tail) { - ENTER(normalizeLet); - AnfExp *body = normalize(lamLet->body, tail); - int save = PROTECT(body); - AnfExp *exp = normalizeLetBindings(lamLet->bindings, body); - UNPROTECT(save); - LEAVE(normalizeLet); - return exp; -} - -static AnfExp *normalizeLetStar(LamLetStar *lamLetStar, AnfExp *tail) { - ENTER(normalizeLetStar); - AnfExp *body = normalize(lamLetStar->body, tail); - int save = PROTECT(body); - AnfExp *exp = normalizeLetStarBindings(lamLetStar->bindings, body); - UNPROTECT(save); - LEAVE(normalizeLetStar); - return exp; -} - -static LamPrimApp *deconstructToPrimApp(LamDeconstruct *deconstruct) { - LamExp *index = - newLamExp_Stdint(CPI(deconstruct), deconstruct->vec); - int save = PROTECT(index); - LamPrimApp *res = - newLamPrimApp(CPI(deconstruct), LAMPRIMOP_TYPE_VEC, index, deconstruct->exp); - UNPROTECT(save); - return res; -} - -static LamPrimApp *tagToPrimApp(LamExp *tagged) { - LamExp *index = newLamExp_Stdint(CPI(tagged), 0); - int save = PROTECT(index); - LamPrimApp *res = newLamPrimApp(CPI(tagged), LAMPRIMOP_TYPE_VEC, index, tagged); - UNPROTECT(save); - return res; -} - -static AnfExp *normalizeDeconstruct(LamDeconstruct *deconstruct, AnfExp *tail) { - ENTER(noramaalizeDeconstruct); - LamPrimApp *primApp = deconstructToPrimApp(deconstruct); - int save = PROTECT(primApp); - AnfExp *res = normalizePrim(primApp, tail); - UNPROTECT(save); - LEAVE(noramaalizeDeconstruct); - return res; -} - -static LamPrimApp *tupleIndexToPrimApp(LamTupleIndex *tupleIndex) { - LamExp *index = - newLamExp_Stdint(CPI(tupleIndex), tupleIndex->vec); - int save = PROTECT(index); - LamPrimApp *res = - newLamPrimApp(CPI(tupleIndex), LAMPRIMOP_TYPE_VEC, index, tupleIndex->exp); - UNPROTECT(save); - return res; -} - -static AnfExp *normalizeTupleIndex(LamTupleIndex *index, AnfExp *tail) { - ENTER(noramaalizeTupleIndex); - LamPrimApp *primApp = tupleIndexToPrimApp(index); - int save = PROTECT(primApp); - AnfExp *res = normalizePrim(primApp, tail); - UNPROTECT(save); - LEAVE(noramaalizeTupleIndex); - return res; -} - - -static AnfExp *normalizeTag(LamExp *tagged, AnfExp *tail) { - ENTER(noramaalizeTag); - LamPrimApp *primApp = tagToPrimApp(tagged); - int save = PROTECT(primApp); - AnfExp *res = normalizePrim(primApp, tail); - UNPROTECT(save); - LEAVE(noramaalizeTag); - return res; -} - -static AnfExp *normalizeLetRec(LamLetRec *lamLetRec, AnfExp *tail) { +static AnfExp *normalizeLetRec(MinLetRec *minLetRec, AnfExp *tail) { ENTER(normalizeLetRec); - IFDEBUG(ppLamLetRec(lamLetRec)); - AnfExp *body = normalize(lamLetRec->body, tail); + IFDEBUG(ppMinLetRec(minLetRec)); + AnfExp *body = normalize(minLetRec->body, tail); int save = PROTECT(body); CexpLetRec *cexpLetRec = newCexpLetRec(CPI(body), 0, NULL, body); PROTECT(cexpLetRec); - cexpLetRec = normalizeLetRecBindings(cexpLetRec, lamLetRec->bindings); + cexpLetRec = normalizeLetRecBindings(cexpLetRec, minLetRec->bindings); PROTECT(cexpLetRec); if (cexpLetRec->bindings == NULL) { UNPROTECT(save); @@ -400,11 +249,11 @@ static AnfExp *normalizeBack(ParserInfo I, AnfExp *tail) { return exp; } -static AnfExp *normalizeCallCc(LamExp *lamExp, AnfExp *tail) { +static AnfExp *normalizeCallCc(MinExp *minExp, AnfExp *tail) { ENTER(normalizeCallCc); - LamExpTable *replacements = makeLamExpHashTable(); + MinExpTable *replacements = newMinExpTable(); int save = PROTECT(replacements); - Aexp *aexp = replaceLamExp(lamExp, replacements); + Aexp *aexp = replaceMinExp(minExp, replacements); int save2 = PROTECT(aexp); Cexp *cexp = newCexp_CallCC(CPI(aexp), aexp); REPLACE_PROTECT(save2, cexp); @@ -418,35 +267,17 @@ static AnfExp *normalizeCallCc(LamExp *lamExp, AnfExp *tail) { return res; } -static LamApply *printToApply(LamPrint *lamPrint) { - LamArgs *args = newLamArgs(CPI(lamPrint), lamPrint->exp, NULL); - int save = PROTECT(args); - LamApply *lamApply = newLamApply(CPI(lamPrint), lamPrint->printer, args); - UNPROTECT(save); - return lamApply; -} - -static AnfExp *normalizePrint(LamPrint *lamPrint, AnfExp *tail) { - ENTER(normalizePrint); - LamApply *lamApply = printToApply(lamPrint); - int save = PROTECT(lamApply); - AnfExp *res = normalizeApply(lamApply, tail); - UNPROTECT(save); - LEAVE(normalizePrint); - return res; -} - -static AnfExp *normalizeIff(LamIff *lamIff, AnfExp *tail) { +static AnfExp *normalizeIff(MinIff *minIff, AnfExp *tail) { ENTER(normalizeIff); - LamExpTable *replacements = makeLamExpHashTable(); + MinExpTable *replacements = newMinExpTable(); int save = PROTECT(replacements); - Aexp *condition = replaceLamExp(lamIff->condition, replacements); + Aexp *condition = replaceMinExp(minIff->condition, replacements); int save2 = PROTECT(condition); - AnfExp *consequent = normalize(lamIff->consequent, NULL); + AnfExp *consequent = normalize(minIff->consequent, NULL); PROTECT(consequent); - AnfExp *alternative = normalize(lamIff->alternative, NULL); + AnfExp *alternative = normalize(minIff->alternative, NULL); PROTECT(alternative); - Cexp *cexp = makeCexp_Iff(CPI(lamIff), condition, consequent, alternative); + Cexp *cexp = makeCexp_Iff(CPI(minIff), condition, consequent, alternative); REPLACE_PROTECT(save2, cexp); AnfExp *exp = wrapCexp(cexp); REPLACE_PROTECT(save2, exp); @@ -458,16 +289,16 @@ static AnfExp *normalizeIff(LamIff *lamIff, AnfExp *tail) { return res; } -static AnfExp *normalizeMakeVec(LamMakeVec *lamMakeVec, AnfExp *tail) { +// args can be null so we need to pass in PI +static AnfExp *normalizeMakeVec(ParserInfo PI, MinExprList *minMakeVec, + AnfExp *tail) { ENTER(normalizeMakeVec); - LamExpTable *replacements = makeLamExpHashTable(); + MinExpTable *replacements = newMinExpTable(); int save = PROTECT(replacements); - DEBUG("calling replaceLamArgs"); - AexpList *args = replaceLamArgs(lamMakeVec->args, replacements); + DEBUG("calling replaceMinArgs"); + AexpList *args = replaceMinArgs(minMakeVec, replacements); int save2 = PROTECT(args); - AexpMakeVec *aexpMakeVec = newAexpMakeVec(CPI(lamMakeVec), countAexpList(args), args); - REPLACE_PROTECT(save2, aexpMakeVec); - Aexp *aexp = newAexp_MakeVec(CPI(aexpMakeVec), aexpMakeVec); + Aexp *aexp = makeAexp_MakeVec(PI, countAexpList(args), args); REPLACE_PROTECT(save2, aexp); AnfExp *exp = wrapAexp(aexp); REPLACE_PROTECT(save2, exp); @@ -479,42 +310,6 @@ static AnfExp *normalizeMakeVec(LamMakeVec *lamMakeVec, AnfExp *tail) { return res; } -static LamMakeVec *constructToMakeVec(LamConstruct *construct) { - int nArgs = countLamArgs(construct->args); - LamExp *newArg = - newLamExp_Stdint(CPI(construct), construct->tag); - int save = PROTECT(newArg); - LamArgs *extraItem = newLamArgs(CPI(construct), newArg, construct->args); - PROTECT(extraItem); - LamMakeVec *res = newLamMakeVec(CPI(construct), nArgs + 1, extraItem); - UNPROTECT(save); - return res; -} - -static LamMakeVec *tupleToMakeVec(ParserInfo PI, LamArgs *tuple) { - int nArgs = countLamArgs(tuple); - LamMakeVec *res = newLamMakeVec(PI, nArgs, tuple); - return res; -} - -static AnfExp *normalizeConstruct(LamConstruct *construct, AnfExp *tail) { - ENTER(normalizeConstruct); - LamMakeVec *makeVec = constructToMakeVec(construct); - int save = PROTECT(makeVec); - AnfExp *res = normalizeMakeVec(makeVec, tail); - UNPROTECT(save); - LEAVE(normalizeConstruct); - return res; -} - -static AnfExp *normalizeMakeTuple(ParserInfo PI, LamArgs *tuple, AnfExp *tail) { - LamMakeVec *makeVec = tupleToMakeVec(PI, tuple); - int save = PROTECT(makeVec); - AnfExp *res = normalizeMakeVec(makeVec, tail); - UNPROTECT(save); - return res; -} - // sequences are not covered by the algorithm // however the algorithm states that "All non-atomic // (complex) expressions must be let-bound or appear @@ -538,7 +333,7 @@ static AnfExp *normalizeMakeTuple(ParserInfo PI, LamArgs *tuple, AnfExp *tail) { // (let (anf$123 (expr1)) (expr2 anf$123)) // and a tail and we want to build // (let (anf$123 (expr1)) (let (f (expr2 anf$123)) )) -static AnfExp *normalizeSequence(LamSequence *sequence, AnfExp *tail) { +static AnfExp *normalizeSequence(MinExprList *sequence, AnfExp *tail) { ENTER(normalizeSequence); if (sequence == NULL) { cant_happen("empty sequence in normalizeSequence"); @@ -569,13 +364,13 @@ static AnfExp *wrapTail(AnfExp *exp, AnfExp *tail) { return exp; } -static AnfExp *normalizePrim(LamPrimApp *app, AnfExp *tail) { +static AnfExp *normalizePrim(MinPrimApp *app, AnfExp *tail) { ENTER(normalizePrim); - LamExpTable *replacements = makeLamExpHashTable(); + MinExpTable *replacements = newMinExpTable(); int save = PROTECT(replacements); - Aexp *exp1 = replaceLamExp(app->exp1, replacements); + Aexp *exp1 = replaceMinExp(app->exp1, replacements); PROTECT(exp1); - Aexp *exp2 = replaceLamExp(app->exp2, replacements); + Aexp *exp2 = replaceMinExp(app->exp2, replacements); PROTECT(exp2); Aexp *aexp = makeAexp_Prim(CPI(app), mapPrimOp(app->type), exp1, exp2); PROTECT(aexp); @@ -589,14 +384,12 @@ static AnfExp *normalizePrim(LamPrimApp *app, AnfExp *tail) { return res; } -static AnfExp *normalizeAmb(LamAmb *app, AnfExp *tail) { +static AnfExp *normalizeAmb(MinAmb *app, AnfExp *tail) { AnfExp *left = normalize(app->left, NULL); int save = PROTECT(left); AnfExp *right = normalize(app->right, NULL); PROTECT(right); - CexpAmb *amb = newCexpAmb(CPI(app), left, right); - PROTECT(amb); - Cexp *cexp = newCexp_Amb(CPI(amb), amb); + Cexp *cexp = makeCexp_Amb(CPI(app), left, right); PROTECT(cexp); AnfExp *exp = wrapCexp(cexp); PROTECT(exp); @@ -619,7 +412,8 @@ static AnfExp *normalizeVar(ParserInfo I, HashSymbol *var, AnfExp *tail) { return exp; } -static AnfExp *normalizeCharacter(ParserInfo I, Character character, AnfExp *tail) { +static AnfExp *normalizeCharacter(ParserInfo I, Character character, + AnfExp *tail) { ENTER(normalizeCharacter); if (tail != NULL) { LEAVE(normalizeCharacter); @@ -633,7 +427,8 @@ static AnfExp *normalizeCharacter(ParserInfo I, Character character, AnfExp *tai return exp; } -static AnfExp *normalizeMaybeBigInteger(ParserInfo I, MaybeBigInt *integer, AnfExp *tail) { +static AnfExp *normalizeMaybeBigInteger(ParserInfo I, MaybeBigInt *integer, + AnfExp *tail) { ENTER(normalizeMaybeBigInteger); if (tail != NULL) { LEAVE(normalizeMaybeBigInteger); @@ -661,13 +456,12 @@ static AnfExp *normalizeStdInteger(ParserInfo I, int integer, AnfExp *tail) { return exp; } -static AnfExp *normalizeNameSpaces(ParserInfo I, LamNameSpaceArray *nsArray, AnfExp *tail) { +static AnfExp *normalizeNameSpaces(ParserInfo I, MinNameSpaceArray *nsArray, + AnfExp *tail) { ENTER(normalizeNameSpaces); AexpNameSpaceArray *nsa = aexpNormalizeNameSpaces(I, nsArray); int save = PROTECT(nsa); - AexpNameSpaces *nso = newAexpNameSpaces(I, nsa, tail); - PROTECT(nso); - Aexp *aexp = newAexp_NameSpaces(I, nso); + Aexp *aexp = makeAexp_NameSpaces(I, nsa, tail); PROTECT(aexp); AnfExp *exp = wrapAexp(aexp); UNPROTECT(save); @@ -675,7 +469,8 @@ static AnfExp *normalizeNameSpaces(ParserInfo I, LamNameSpaceArray *nsArray, Anf return exp; } -static AexpNameSpaceArray *aexpNormalizeNameSpaces(ParserInfo I, LamNameSpaceArray *nsArray) { +static AexpNameSpaceArray *aexpNormalizeNameSpaces(ParserInfo I, + MinNameSpaceArray *nsArray) { ENTER(aexpNormalizeNameSpaces); AexpNameSpaceArray *res = newAexpNameSpaceArray(); int save = PROTECT(res); @@ -699,47 +494,46 @@ static AnfExp *normalizeEnv(ParserInfo I, AnfExp *tail) { return tail; } AnfExp *exp = newAnfExp_Env(I); - LEAVE(normalizeLam); + LEAVE(normalizeMin); return exp; } -static AnfExp *normalizeLamLookUp(LamLookUp *lookUp, AnfExp *tail) { +static AnfExp *normalizeMinLookUp(MinLookUp *lookUp, AnfExp *tail) { AnfExp *rest = normalize(lookUp->exp, tail); int save = PROTECT(rest); - AnfExpLookUp *exp = newAnfExpLookUp(CPI(lookUp), lookUp->nsId, rest); - PROTECT(exp); - AnfExp *res = newAnfExp_LookUp(CPI(exp), exp); + AnfExp *res = makeAnfExp_LookUp(CPI(lookUp), lookUp->nsId, rest); UNPROTECT(save); return res; } -static AnfExp *normalizeLam(LamLam *lamLam, AnfExp *tail) { - ENTER(normalizeLam); +static AnfExp *normalizeMin(MinLam *minMin, AnfExp *tail) { + ENTER(normalizeMin); if (tail != NULL) { - LEAVE(normalizeLam); + LEAVE(normalizeMin); return tail; } - Aexp *aexp = aexpNormalizeLam(lamLam); + Aexp *aexp = aexpNormalizeLam(minMin); int save = PROTECT(aexp); AnfExp *exp = wrapAexp(aexp); UNPROTECT(save); - LEAVE(normalizeLam); + LEAVE(normalizeMin); return exp; } -static Aexp *aexpNormalizeLam(LamLam *lamLam) { +static Aexp *aexpNormalizeLam(MinLam *minMin) { ENTER(aexpNormalizeLam); - AexpVarList *varList = convertVarList(lamLam->args); + AexpVarList *varList = convertVarList(minMin->args); int save = PROTECT(varList); - AnfExp *body = normalize(lamLam->exp, NULL); + AnfExp *body = normalize(minMin->exp, NULL); PROTECT(body); - Aexp *aexp = makeAexp_Lam(CPI(lamLam), countAexpVarList(varList), 0, varList, body); + Aexp *aexp = + makeAexp_Lam(CPI(minMin), countAexpVarList(varList), 0, varList, body); UNPROTECT(save); LEAVE(aexpNormalizeLam); return aexp; } -static AexpIntList *convertIntList(LamIntList *list) { +static AexpIntList *convertIntList(MinIntList *list) { ENTER(convertIntList); if (list == NULL) { LEAVE(convertIntList); @@ -753,7 +547,7 @@ static AexpIntList *convertIntList(LamIntList *list) { return this; } -static AexpVarList *convertVarList(LamVarList *args) { +static AexpVarList *convertVarList(SymbolList *args) { ENTER(convertVarList); if (args == NULL) { LEAVE(convertVarList); @@ -761,28 +555,25 @@ static AexpVarList *convertVarList(LamVarList *args) { } AexpVarList *next = convertVarList(args->next); int save = PROTECT(next); - AexpVarList *this = newAexpVarList(CPI(args), args->var, next); + AexpVarList *this = newAexpVarList(CPI(args), args->symbol, next); UNPROTECT(save); LEAVE(convertVarList); return this; } -static LamExpTable *makeLamExpHashTable() { - return newLamExpTable(); -} - -static AnfExp *normalizeApply(LamApply *lamApply, AnfExp *tail) { +static AnfExp *normalizeApply(MinApply *minApply, AnfExp *tail) { ENTER(normalizeApply); - LamExpTable *replacements = makeLamExpHashTable(); + MinExpTable *replacements = newMinExpTable(); int save = PROTECT(replacements); - Aexp *function = replaceLamExp(lamApply->function, replacements); + Aexp *function = replaceMinExp(minApply->function, replacements); int save2 = PROTECT(function); - DEBUG("calling replaceLamArgs"); - AexpList *args = replaceLamArgs(lamApply->args, replacements); + DEBUG("calling replaceMinArgs"); + AexpList *args = replaceMinArgs(minApply->args, replacements); PROTECT(args); - DEBUG("back from replaceLamArgs"); - IFDEBUG(printLamExpTable(replacements, 0)); - Cexp *cexp = makeCexp_Apply(CPI(lamApply), function, countAexpList(args), args); + DEBUG("back from replaceMinArgs"); + IFDEBUG(printMinExpTable(replacements, 0)); + Cexp *cexp = + makeCexp_Apply(CPI(minApply), function, countAexpList(args), args); REPLACE_PROTECT(save2, cexp); AnfExp *exp = wrapCexp(cexp); REPLACE_PROTECT(save2, exp); @@ -795,22 +586,22 @@ static AnfExp *normalizeApply(LamApply *lamApply, AnfExp *tail) { return res; } -static AnfExp *letBind(AnfExp *body, LamExpTable *replacements) { +static AnfExp *letBind(AnfExp *body, MinExpTable *replacements) { ENTER(letBind); // DEBUG("sleep %d", sleep(1)); IFDEBUG(printExp(body, 0)); - IFDEBUG(printLamExpTable(replacements, 0)); - if (countLamExpTable(replacements) == 0) { + IFDEBUG(printMinExpTable(replacements, 0)); + if (countMinExpTable(replacements) == 0) { LEAVE(letBind); return body; } int save = PROTECT(body); - LamExp *lamExpVal = NULL; + MinExp *minExpVal = NULL; Index i = 0; HashSymbol *key = NULL; - while ((key = iterateLamExpTable(replacements, &i, &lamExpVal)) != NULL) { + while ((key = iterateMinExpTable(replacements, &i, &minExpVal)) != NULL) { DEBUG("letBind iteration %d", i); - AnfExp *exp = normalize(lamExpVal, NULL); + AnfExp *exp = normalize(minExpVal, NULL); int save2 = PROTECT(exp); AnfExpLet *let = newAnfExpLet(CPI(exp), key, exp, body); PROTECT(let); @@ -840,19 +631,20 @@ static Aexp *aexpNormalizeCharacter(ParserInfo I, Character character) { return newAexp_Character(I, character); } -static CexpIntCondCases *normalizeIntCondCases(LamIntCondCases *cases) { +static CexpIntCondCases *normalizeIntCondCases(MinIntCondCases *cases) { if (cases == NULL) return NULL; CexpIntCondCases *next = normalizeIntCondCases(cases->next); int save = PROTECT(next); AnfExp *body = normalize(cases->body, NULL); PROTECT(body); - CexpIntCondCases *this = newCexpIntCondCases(CPI(cases), cases->constant, body, next); + CexpIntCondCases *this = + newCexpIntCondCases(CPI(cases), cases->constant, body, next); UNPROTECT(save); return this; } -static CexpCharCondCases *normalizeCharCondCases(LamCharCondCases *cases) { +static CexpCharCondCases *normalizeCharCondCases(MinCharCondCases *cases) { if (cases == NULL) return NULL; CexpCharCondCases *next = normalizeCharCondCases(cases->next); @@ -865,7 +657,7 @@ static CexpCharCondCases *normalizeCharCondCases(LamCharCondCases *cases) { return this; } -static CexpCondCases *normalizeCondCases(LamCondCases *cases) { +static CexpCondCases *normalizeCondCases(MinCondCases *cases) { ENTER(normalizeCondCases); if (cases == NULL) { LEAVE(normalizeCondCases); @@ -874,161 +666,115 @@ static CexpCondCases *normalizeCondCases(LamCondCases *cases) { CexpCondCases *res = NULL; int save = PROTECT(NULL); switch (cases->type) { - case LAMCONDCASES_TYPE_INTEGERS:{ - CexpIntCondCases *intCases = - normalizeIntCondCases(getLamCondCases_Integers(cases)); - PROTECT(intCases); - res = newCexpCondCases_IntCases(CPI(cases), intCases); - } - break; - case LAMCONDCASES_TYPE_CHARACTERS:{ - CexpCharCondCases *charCases = - normalizeCharCondCases(getLamCondCases_Characters(cases)); - PROTECT(charCases); - res = newCexpCondCases_CharCases(CPI(cases), charCases); - } - break; - default: - cant_happen("unrecognized type %d in normlizeCondCases", - cases->type); + case MINCONDCASES_TYPE_INTEGERS: { + CexpIntCondCases *intCases = + normalizeIntCondCases(getMinCondCases_Integers(cases)); + PROTECT(intCases); + res = newCexpCondCases_IntCases(CPI(cases), intCases); + } break; + case MINCONDCASES_TYPE_CHARACTERS: { + CexpCharCondCases *charCases = + normalizeCharCondCases(getMinCondCases_Characters(cases)); + PROTECT(charCases); + res = newCexpCondCases_CharCases(CPI(cases), charCases); + } break; + default: + cant_happen("unrecognized type %d in normlizeCondCases", cases->type); } UNPROTECT(save); LEAVE(normalizeCondCases); return res; } -static Aexp *replaceLamDeconstruct(LamDeconstruct *lamDeconstruct, - LamExpTable *replacements) { - LamPrimApp *primApp = deconstructToPrimApp(lamDeconstruct); - int save = PROTECT(primApp); - Aexp *res = replaceLamPrim(primApp, replacements); - UNPROTECT(save); - return res; -} - -static Aexp *replaceLamTag(LamExp *tagged, LamExpTable *replacements) { - LamPrimApp *primApp = tagToPrimApp(tagged); - int save = PROTECT(primApp); - Aexp *res = replaceLamPrim(primApp, replacements); - UNPROTECT(save); - return res; -} - -static Aexp *replaceLamExp(LamExp *lamExp, LamExpTable *replacements) { - ENTER(replaceLamExp); +static Aexp *replaceMinExp(MinExp *minExp, MinExpTable *replacements) { + ENTER(replaceMinExp); Aexp *res = NULL; - switch (lamExp->type) { - case LAMEXP_TYPE_LAM: - res = aexpNormalizeLam(getLamExp_Lam(lamExp)); - break; - case LAMEXP_TYPE_VAR: - res = aexpNormalizeVar(CPI(lamExp), getLamExp_Var(lamExp)); - break; - case LAMEXP_TYPE_BIGINTEGER: - res = aexpNormalizeMaybeBigInteger(CPI(lamExp), getLamExp_BigInteger(lamExp)); - break; - case LAMEXP_TYPE_STDINT: - res = aexpNormalizeStdInteger(CPI(lamExp), getLamExp_Stdint(lamExp)); - break; - case LAMEXP_TYPE_PRIM: - res = replaceLamPrim(getLamExp_Prim(lamExp), replacements); - break; - case LAMEXP_TYPE_PRINT: - res = replaceLamPrint(getLamExp_Print(lamExp), replacements); - break; - case LAMEXP_TYPE_MAKEVEC: - res = replaceLamMakeVec(getLamExp_MakeVec(lamExp), replacements); - break; - case LAMEXP_TYPE_CONSTRUCT: - res = replaceLamConstruct(getLamExp_Construct(lamExp), replacements); - break; - case LAMEXP_TYPE_TAG: - res = replaceLamTag(getLamExp_Tag(lamExp), replacements); - break; - case LAMEXP_TYPE_CONSTANT: - res = aexpNormalizeStdInteger(CPI(lamExp), getLamExp_Constant(lamExp)->tag); - break; - case LAMEXP_TYPE_TYPEDEFS: - res = replaceLamCexp(getLamExp_TypeDefs(lamExp)->body, replacements); - break; - case LAMEXP_TYPE_DECONSTRUCT: - res = - replaceLamDeconstruct(getLamExp_Deconstruct(lamExp), replacements); - break; - case LAMEXP_TYPE_CHARACTER: - res = aexpNormalizeCharacter(CPI(lamExp), getLamExp_Character(lamExp)); - break; - case LAMEXP_TYPE_LOOKUP: - case LAMEXP_TYPE_SEQUENCE: - case LAMEXP_TYPE_APPLY: - case LAMEXP_TYPE_IFF: - case LAMEXP_TYPE_CALLCC: - case LAMEXP_TYPE_LETREC: - case LAMEXP_TYPE_LET: - case LAMEXP_TYPE_MATCH: - case LAMEXP_TYPE_COND: - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_AMB: - case LAMEXP_TYPE_MAKETUPLE: - res = replaceLamCexp(lamExp, replacements); - break; - default: - cant_happen("unrecognised type %s", lamExpTypeName(lamExp->type)); + switch (minExp->type) { + case MINEXP_TYPE_LAM: + res = aexpNormalizeLam(getMinExp_Lam(minExp)); + break; + case MINEXP_TYPE_VAR: + res = aexpNormalizeVar(CPI(minExp), getMinExp_Var(minExp)); + break; + case MINEXP_TYPE_BIGINTEGER: + res = aexpNormalizeMaybeBigInteger(CPI(minExp), + getMinExp_BigInteger(minExp)); + break; + case MINEXP_TYPE_STDINT: + res = aexpNormalizeStdInteger(CPI(minExp), getMinExp_Stdint(minExp)); + break; + case MINEXP_TYPE_PRIM: + res = replaceMinPrim(getMinExp_Prim(minExp), replacements); + break; + case MINEXP_TYPE_MAKEVEC: + res = replaceMinMakeVec(getMinExp_MakeVec(minExp), replacements); + break; + case MINEXP_TYPE_CHARACTER: + res = aexpNormalizeCharacter(CPI(minExp), getMinExp_Character(minExp)); + break; + case MINEXP_TYPE_LOOKUP: + case MINEXP_TYPE_SEQUENCE: + case MINEXP_TYPE_APPLY: + case MINEXP_TYPE_IFF: + case MINEXP_TYPE_CALLCC: + case MINEXP_TYPE_LETREC: + case MINEXP_TYPE_MATCH: + case MINEXP_TYPE_COND: + case MINEXP_TYPE_BACK: + case MINEXP_TYPE_ERROR: + case MINEXP_TYPE_AMB: + res = replaceMinCexp(minExp, replacements); + break; + default: + cant_happen("unrecognised type %s", minExpTypeName(minExp->type)); } - LEAVE(replaceLamExp); + LEAVE(replaceMinExp); return res; } -static bool lamExpIsLambda(LamExp *val) { +static bool minExpIsMinbda(MinExp *val) { switch (val->type) { - case LAMEXP_TYPE_LAM: - return true; - case LAMEXP_TYPE_VAR: - case LAMEXP_TYPE_BIGINTEGER: - case LAMEXP_TYPE_CHARACTER: - case LAMEXP_TYPE_CONSTANT: - case LAMEXP_TYPE_CONSTRUCT: - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_AMB: - case LAMEXP_TYPE_PRIM: - case LAMEXP_TYPE_SEQUENCE: - case LAMEXP_TYPE_APPLY: - case LAMEXP_TYPE_IFF: - case LAMEXP_TYPE_CALLCC: - case LAMEXP_TYPE_LETREC: - case LAMEXP_TYPE_TYPEDEFS: - case LAMEXP_TYPE_LET: - case LAMEXP_TYPE_MATCH: - case LAMEXP_TYPE_COND: - case LAMEXP_TYPE_MAKEVEC: - case LAMEXP_TYPE_LOOKUP: - case LAMEXP_TYPE_MAKETUPLE: - case LAMEXP_TYPE_TUPLEINDEX: - return false; - default: - cant_happen("unrecognised LamExp type %s in lamExpIsLambda", - lamExpTypeName(val->type)); + case MINEXP_TYPE_LAM: + return true; + case MINEXP_TYPE_VAR: + case MINEXP_TYPE_BIGINTEGER: + case MINEXP_TYPE_CHARACTER: + case MINEXP_TYPE_BACK: + case MINEXP_TYPE_ERROR: + case MINEXP_TYPE_AMB: + case MINEXP_TYPE_PRIM: + case MINEXP_TYPE_SEQUENCE: + case MINEXP_TYPE_APPLY: + case MINEXP_TYPE_IFF: + case MINEXP_TYPE_CALLCC: + case MINEXP_TYPE_LETREC: + case MINEXP_TYPE_MATCH: + case MINEXP_TYPE_COND: + case MINEXP_TYPE_MAKEVEC: + case MINEXP_TYPE_LOOKUP: + return false; + default: + cant_happen("unrecognised MinExp type %s in minExpIsMinbda", + minExpTypeName(val->type)); } } static CexpLetRec *normalizeLetRecBindings(CexpLetRec *cexpLetRec, - LamBindings *lamLetRecBindings) { - if (lamLetRecBindings == NULL) { + MinBindings *minLetRecBindings) { + if (minLetRecBindings == NULL) { return cexpLetRec; } - cexpLetRec = normalizeLetRecBindings(cexpLetRec, lamLetRecBindings->next); + cexpLetRec = normalizeLetRecBindings(cexpLetRec, minLetRecBindings->next); int save = PROTECT(cexpLetRec); - if (lamExpIsLambda(lamLetRecBindings->val)) { - Aexp *val = replaceLamExp(lamLetRecBindings->val, NULL); + if (minExpIsMinbda(minLetRecBindings->val)) { + Aexp *val = replaceMinExp(minLetRecBindings->val, NULL); PROTECT(val); cexpLetRec->bindings = - newAnfLetRecBindings(CPI(lamLetRecBindings), lamLetRecBindings->var, val, - cexpLetRec->bindings); + newAnfLetRecBindings(CPI(minLetRecBindings), minLetRecBindings->var, + val, cexpLetRec->bindings); cexpLetRec->nBindings++; } else { - AnfExp *val = normalize(lamLetRecBindings->val, NULL); + AnfExp *val = normalize(minLetRecBindings->val, NULL); PROTECT(val); AnfExp *exp = NULL; if (cexpLetRec->bindings != NULL) { @@ -1039,7 +785,8 @@ static CexpLetRec *normalizeLetRecBindings(CexpLetRec *cexpLetRec, } else { exp = cexpLetRec->body; } - AnfExpLet *expLet = newAnfExpLet(CPI(lamLetRecBindings), lamLetRecBindings->var, val, exp); + AnfExpLet *expLet = newAnfExpLet(CPI(minLetRecBindings), + minLetRecBindings->var, val, exp); PROTECT(expLet); exp = newAnfExp_Let(CPI(expLet), expLet); PROTECT(exp); @@ -1049,105 +796,83 @@ static CexpLetRec *normalizeLetRecBindings(CexpLetRec *cexpLetRec, return cexpLetRec; } -static Aexp *replaceLamConstruct(LamConstruct *construct, - LamExpTable *replacements) { - LamMakeVec *makeVec = constructToMakeVec(construct); - int save = PROTECT(makeVec); - Aexp *res = replaceLamMakeVec(makeVec, replacements); - UNPROTECT(save); - return res; -} - -static Aexp *replaceLamMakeVec(LamMakeVec *makeVec, LamExpTable *replacements) { - ENTER(replaceLamMakeVec); - DEBUG("calling replaceLamArgs"); - AexpList *aexpList = replaceLamArgs(makeVec->args, replacements); +static Aexp *replaceMinMakeVec(MinExprList *makeVec, + MinExpTable *replacements) { + ENTER(replaceMinMakeVec); + DEBUG("calling replaceMinArgs"); + AexpList *aexpList = replaceMinArgs(makeVec, replacements); int save = PROTECT(aexpList); AexpMakeVec *aexpMakeVec = newAexpMakeVec(CPI(makeVec), countAexpList(aexpList), aexpList); PROTECT(aexpMakeVec); Aexp *res = newAexp_MakeVec(CPI(makeVec), aexpMakeVec); UNPROTECT(save); - LEAVE(replaceLamMakeVec); - return res; -} - -static Aexp *replaceLamPrint(LamPrint *print, LamExpTable *replacements) { - ENTER(replaceLamPrint); - LamApply *lamApply = printToApply(print); - int save = PROTECT(lamApply); - LamExp *lamExp = newLamExp_Apply(CPI(print), lamApply); - PROTECT(lamExp); - Aexp *res = replaceLamExp(lamExp, replacements); - UNPROTECT(save); - LEAVE(replaceLamPrint); + LEAVE(replaceMinMakeVec); return res; } -static AexpList *replaceLamArgs(LamArgs *list, LamExpTable *replacements) { - ENTER(replaceLamArgs); +static AexpList *replaceMinArgs(MinExprList *list, MinExpTable *replacements) { + ENTER(replaceMinArgs); if (list == NULL) { - LEAVE(replaceLamArgs); + LEAVE(replaceMinArgs); return NULL; } - DEBUG("calling replaceLamArgs"); - AexpList *next = replaceLamArgs(list->next, replacements); + DEBUG("calling replaceMinArgs"); + AexpList *next = replaceMinArgs(list->next, replacements); int save = PROTECT(next); - Aexp *val = replaceLamExp(list->exp, replacements); + Aexp *val = replaceMinExp(list->exp, replacements); PROTECT(val); AexpList *res = newAexpList(CPI(list), val, next); UNPROTECT(save); - LEAVE(replaceLamArgs); + LEAVE(replaceMinArgs); return res; } -static Aexp *replaceLamPrim(LamPrimApp *lamPrimApp, LamExpTable *replacements) { - ENTER(replaceLamPrim); - Aexp *exp1 = replaceLamExp(lamPrimApp->exp1, replacements); +static Aexp *replaceMinPrim(MinPrimApp *minPrimApp, MinExpTable *replacements) { + ENTER(replaceMinPrim); + Aexp *exp1 = replaceMinExp(minPrimApp->exp1, replacements); int save = PROTECT(exp1); - Aexp *exp2 = replaceLamExp(lamPrimApp->exp2, replacements); + Aexp *exp2 = replaceMinExp(minPrimApp->exp2, replacements); PROTECT(exp2); - AexpPrimApp *prim = - newAexpPrimApp(CPI(lamPrimApp), mapPrimOp(lamPrimApp->type), exp1, exp2); - PROTECT(prim); - Aexp *res = newAexp_Prim(CPI(prim), prim); + Aexp *res = + makeAexp_Prim(CPI(minPrimApp), mapPrimOp(minPrimApp->type), exp1, exp2); UNPROTECT(save); - LEAVE(replaceLamPrim); + LEAVE(replaceMinPrim); return res; } -static AexpPrimOp mapPrimOp(LamPrimOp op) { +static AexpPrimOp mapPrimOp(MinPrimOp op) { switch (op) { - case LAMPRIMOP_TYPE_ADD: - return AEXPPRIMOP_TYPE_ADD; - case LAMPRIMOP_TYPE_SUB: - return AEXPPRIMOP_TYPE_SUB; - case LAMPRIMOP_TYPE_MUL: - return AEXPPRIMOP_TYPE_MUL; - case LAMPRIMOP_TYPE_DIV: - return AEXPPRIMOP_TYPE_DIV; - case LAMPRIMOP_TYPE_POW: - return AEXPPRIMOP_TYPE_POW; - case LAMPRIMOP_TYPE_EQ: - return AEXPPRIMOP_TYPE_EQ; - case LAMPRIMOP_TYPE_NE: - return AEXPPRIMOP_TYPE_NE; - case LAMPRIMOP_TYPE_GT: - return AEXPPRIMOP_TYPE_GT; - case LAMPRIMOP_TYPE_LT: - return AEXPPRIMOP_TYPE_LT; - case LAMPRIMOP_TYPE_GE: - return AEXPPRIMOP_TYPE_GE; - case LAMPRIMOP_TYPE_LE: - return AEXPPRIMOP_TYPE_LE; - case LAMPRIMOP_TYPE_VEC: - return AEXPPRIMOP_TYPE_VEC; - case LAMPRIMOP_TYPE_MOD: - return AEXPPRIMOP_TYPE_MOD; - case LAMPRIMOP_TYPE_CMP: - return AEXPPRIMOP_TYPE_CMP; - default: - cant_happen("unrecognised op type %d in mapPrimOp", op); + case MINPRIMOP_TYPE_ADD: + return AEXPPRIMOP_TYPE_ADD; + case MINPRIMOP_TYPE_SUB: + return AEXPPRIMOP_TYPE_SUB; + case MINPRIMOP_TYPE_MUL: + return AEXPPRIMOP_TYPE_MUL; + case MINPRIMOP_TYPE_DIV: + return AEXPPRIMOP_TYPE_DIV; + case MINPRIMOP_TYPE_POW: + return AEXPPRIMOP_TYPE_POW; + case MINPRIMOP_TYPE_EQ: + return AEXPPRIMOP_TYPE_EQ; + case MINPRIMOP_TYPE_NE: + return AEXPPRIMOP_TYPE_NE; + case MINPRIMOP_TYPE_GT: + return AEXPPRIMOP_TYPE_GT; + case MINPRIMOP_TYPE_LT: + return AEXPPRIMOP_TYPE_LT; + case MINPRIMOP_TYPE_GE: + return AEXPPRIMOP_TYPE_GE; + case MINPRIMOP_TYPE_LE: + return AEXPPRIMOP_TYPE_LE; + case MINPRIMOP_TYPE_VEC: + return AEXPPRIMOP_TYPE_VEC; + case MINPRIMOP_TYPE_MOD: + return AEXPPRIMOP_TYPE_MOD; + case MINPRIMOP_TYPE_CMP: + return AEXPPRIMOP_TYPE_CMP; + default: + cant_happen("unrecognised op type %d in mapPrimOp", op); } } @@ -1157,14 +882,14 @@ static HashSymbol *freshSymbol() { return res; } -static Aexp *replaceLamCexp(LamExp *apply, LamExpTable *replacements) { - ENTER(replaceLamCexp); +static Aexp *replaceMinCexp(MinExp *apply, MinExpTable *replacements) { + ENTER(replaceMinCexp); if (replacements == NULL) { - cant_happen("replaceLamCexp called with null replacements"); + cant_happen("replaceMinCexp called with null replacements"); } HashSymbol *subst = freshSymbol(); - setLamExpTable(replacements, subst, apply); - IFDEBUG(printLamExpTable(replacements, 0)); - LEAVE(replaceLamCexp); + setMinExpTable(replacements, subst, apply); + IFDEBUG(printMinExpTable(replacements, 0)); + LEAVE(replaceMinCexp); return newAexp_Var(CPI(apply), subst); } diff --git a/src/anf_normalize.h b/src/anf_normalize.h index a916cedc..c862a850 100644 --- a/src/anf_normalize.h +++ b/src/anf_normalize.h @@ -1,5 +1,5 @@ #ifndef cekf_anf_normalize_h -# define cekf_anf_normalize_h +#define cekf_anf_normalize_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2025 Bill Hails @@ -18,9 +18,9 @@ * along with this program. If not, see . */ -# include "lambda.h" -# include "anf.h" +#include "anf.h" +#include "minlam.h" -AnfExp *anfNormalize(LamExp *exp); +AnfExp *anfNormalize(MinExp *exp); #endif diff --git a/src/anf_normalize_2.c b/src/anf_normalize_2.c index 6b1a5072..79c1aebc 100644 --- a/src/anf_normalize_2.c +++ b/src/anf_normalize_2.c @@ -31,8 +31,8 @@ #include "anf_kont.h" #include "common.h" -#include "lambda.h" -#include "lambda_pp.h" +#include "minlam.h" +#include "minlam_pp.h" #include "symbol.h" #include @@ -47,33 +47,33 @@ #include "debugging_off.h" #endif -static ParserInfo NULLPI = (ParserInfo){.lineNo = 0, .fileName = ""}; +static MinExp *normalize(MinExp *exp, AnfKont *k); -static LamExp *normalize(LamExp *exp, AnfKont *k); - -static inline LamExp *INVOKE(AnfKont *k, LamExp *arg) { +static inline MinExp *INVOKE(AnfKont *k, MinExp *arg) { return k->wrapper(arg, k->env); } -static LamExp *makeSingleLet(HashSymbol *y, LamExp *e, LamExp *body) { - LamBindings *bindings = newLamBindings(CPI(e), y, e, NULL); - int save = PROTECT(bindings); - LamExp *res = makeLamExp_Let(CPI(e), bindings, body); +static MinExp *makeSingleLambda(HashSymbol *y, MinExp *e, MinExp *body) { + SymbolList *fargs = newSymbolList(CPI(e), y, NULL); + int save = PROTECT(fargs); + MinExp *lam = makeMinExp_Lam(CPI(body), fargs, body); + PROTECT(lam); + MinExprList *aargs = newMinExprList(CPI(e), e, NULL); + PROTECT(aargs); + MinExp *res = makeMinExp_Apply(CPI(e), lam, aargs); UNPROTECT(save); return res; } -static bool isValueExp(LamExp *exp) { +static bool isValueExp(MinExp *exp) { switch (exp->type) { - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_BIGINTEGER: - case LAMEXP_TYPE_CHARACTER: - case LAMEXP_TYPE_CONSTANT: - case LAMEXP_TYPE_CONSTRUCTOR: - case LAMEXP_TYPE_ENV: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_STDINT: - case LAMEXP_TYPE_VAR: + 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: return true; default: return false; @@ -83,17 +83,17 @@ static bool isValueExp(LamExp *exp) { // (define (normalize-term e) // (normalize e (λ (x) x))) -static LamExp *normalize_term(LamExp *e) { +static MinExp *normalize_term(MinExp *e) { ENTER(normalize_term); AnfKont *termKont = makeKont_normalizeTerm(); // Identity continuation int save = PROTECT(termKont); - LamExp *result = normalize(e, termKont); + MinExp *result = normalize(e, termKont); UNPROTECT(save); LEAVE(normalize_term); return result; } -static LamExp *normalizeTermKont(LamExp *exp, NormalizeTermKontEnv *k +static MinExp *normalizeTermKont(MinExp *exp, NormalizeTermKontEnv *k __attribute__((unused))) { return exp; } @@ -105,25 +105,25 @@ static LamExp *normalizeTermKont(LamExp *exp, NormalizeTermKontEnv *k // (let ((y (gensym))) // `(let (,y ,x) ,(k y))))))) -static LamExp *normalize_name(LamExp *e, AnfKont *k) { +static MinExp *normalize_name(MinExp *e, AnfKont *k) { ENTER(normalize_name); AnfKont *nameKont = makeKont_normalizeName(k); int save = PROTECT(nameKont); - LamExp *result = normalize(e, nameKont); + MinExp *result = normalize(e, nameKont); UNPROTECT(save); LEAVE(normalize_name); return result; } -static LamExp *normalizeNameKont(LamExp *x, NormalizeNameKontEnv *env) { +static MinExp *normalizeNameKont(MinExp *x, NormalizeNameKontEnv *env) { if (isValueExp(x)) { return INVOKE(env->k, x); } else { - LamExp *y = newLamExp_Var(CPI(x), genSymDollar("")); + MinExp *y = newMinExp_Var(CPI(x), genSymDollar("")); int save = PROTECT(y); - LamExp *body = INVOKE(env->k, y); + MinExp *body = INVOKE(env->k, y); PROTECT(body); - LamExp *letExp = makeSingleLet(y->val.var, x, body); + MinExp *letExp = makeSingleLambda(y->val.var, x, body); UNPROTECT(save); return letExp; } @@ -136,38 +136,38 @@ static LamExp *normalizeNameKont(LamExp *x, NormalizeNameKontEnv *env) { // (normalize-names (cdr Ms) [λ (ts) // (k `(,t . ,ts))])])))) -static LamExp *normalize_names(LamArgs *Ms, AnfKont *k) { +static MinExp *normalize_names(MinExprList *Ms, AnfKont *k) { ENTER(normalize_names); if (Ms == NULL) { - LamExp *nullArgs = newLamExp_Args(NULLPI, NULL); + MinExp *nullArgs = newMinExp_Args(NULLPI, NULL); int save = PROTECT(nullArgs); - LamExp *result = INVOKE(k, nullArgs); + MinExp *result = INVOKE(k, nullArgs); UNPROTECT(save); LEAVE(normalize_names); return result; } AnfKont *k1 = makeKont_normalizeNamesOuter(Ms, k); int save = PROTECT(k1); - LamExp *result = normalize_name(Ms->exp, k1); + MinExp *result = normalize_name(Ms->exp, k1); UNPROTECT(save); LEAVE(normalize_names); return result; } -static LamExp *normalizeNamesOuterKont(LamExp *t, +static MinExp *normalizeNamesOuterKont(MinExp *t, NormalizeNamesOuterKontEnv *env) { AnfKont *k2 = makeKont_normalizeNamesInner(t, env->k); int save = PROTECT(k2); - LamExp *result = normalize_names(env->Ms->next, k2); + MinExp *result = normalize_names(env->Ms->next, k2); UNPROTECT(save); return result; } -static LamExp *normalizeNamesInnerKont(LamExp *ts, +static MinExp *normalizeNamesInnerKont(MinExp *ts, NormalizeNamesInnerKontEnv *env) { - LamExp *newArgs = makeLamExp_Args(CPI(env->t), env->t, getLamExp_Args(ts)); + MinExp *newArgs = makeMinExp_Args(CPI(env->t), env->t, getMinExp_Args(ts)); int save = PROTECT(newArgs); - LamExp *result = INVOKE(env->k, newArgs); + MinExp *result = INVOKE(env->k, newArgs); UNPROTECT(save); return result; } @@ -179,26 +179,26 @@ static LamExp *normalizeNamesInnerKont(LamExp *ts, // ,(normalize-term e1) // ,(normalize-term e2)))])) -static LamExp *normalize_Iff(LamExp *exp, AnfKont *k) { +static MinExp *normalize_Iff(MinExp *exp, AnfKont *k) { ENTER(normalize_Iff); - LamIff *iff = getLamExp_Iff(exp); + MinIff *iff = getMinExp_Iff(exp); AnfKont *iffKont = makeKont_normalizeIff(k, iff->consequent, iff->alternative); int save = PROTECT(iffKont); - LamExp *result = normalize_name(iff->condition, iffKont); + MinExp *result = normalize_name(iff->condition, iffKont); UNPROTECT(save); LEAVE(normalize_Iff); return result; } -static LamExp *normalizeIffKont(LamExp *test, NormalizeIffKontEnv *env) { - LamExp *consequent = normalize_term(env->e1); +static MinExp *normalizeIffKont(MinExp *test, NormalizeIffKontEnv *env) { + MinExp *consequent = normalize_term(env->e1); int save = PROTECT(consequent); - LamExp *alternative = normalize_term(env->e2); + MinExp *alternative = normalize_term(env->e2); PROTECT(alternative); - LamExp *ifExp = makeLamExp_Iff(CPI(test), test, consequent, alternative); + MinExp *ifExp = makeMinExp_Iff(CPI(test), test, consequent, alternative); PROTECT(ifExp); - LamExp *result = INVOKE(env->k, ifExp); + MinExp *result = INVOKE(env->k, ifExp); UNPROTECT(save); return result; } @@ -209,31 +209,31 @@ static LamExp *normalizeIffKont(LamExp *test, NormalizeIffKontEnv *env) { // (normalize-names Ms // [λ (ts) (k `(,t . ,ts))])])) -static LamExp *normalize_Apply(LamExp *exp, AnfKont *k) { +static MinExp *normalize_Apply(MinExp *exp, AnfKont *k) { ENTER(normalize_Apply); - AnfKont *k1 = makeKont_normalizeApplyOuter(getLamExp_Apply(exp)->args, k); + AnfKont *k1 = makeKont_normalizeApplyOuter(getMinExp_Apply(exp)->args, k); int save = PROTECT(k1); - LamExp *result = normalize_name(getLamExp_Apply(exp)->function, k1); + MinExp *result = normalize_name(getMinExp_Apply(exp)->function, k1); UNPROTECT(save); LEAVE(normalize_Apply); return result; } -static LamExp *normalizeApplyOuterKont(LamExp *t, +static MinExp *normalizeApplyOuterKont(MinExp *t, NormalizeApplyOuterKontEnv *env) { AnfKont *k2 = makeKont_normalizeApplyInner(t, env->k); int save = PROTECT(k2); - LamExp *result = normalize_names(env->Ms, k2); + MinExp *result = normalize_names(env->Ms, k2); UNPROTECT(save); return result; } -static LamExp *normalizeApplyInnerKont(LamExp *ts, +static MinExp *normalizeApplyInnerKont(MinExp *ts, NormalizeApplyInnerKontEnv *env) { - LamExp *newApply = - makeLamExp_Apply(CPI(env->t), env->t, getLamExp_Args(ts)); + MinExp *newApply = + makeMinExp_Apply(CPI(env->t), env->t, getMinExp_Args(ts)); int save = PROTECT(newApply); - LamExp *result = INVOKE(env->k, newApply); + MinExp *result = INVOKE(env->k, newApply); UNPROTECT(save); return result; } @@ -249,12 +249,12 @@ static LamExp *normalizeApplyInnerKont(LamExp *ts, // [λ (anfrest) // (k `((,x ,anfval) . ,anfrest))])])))) -static LamExp *normalize_bindings(LamBindings *bindings, AnfKont *k) { +static MinExp *normalize_bindings(MinBindings *bindings, AnfKont *k) { ENTER(normalize_bindings); if (bindings == NULL) { - LamExp *nilExp = newLamExp_Bindings(NULLPI, NULL); + MinExp *nilExp = newMinExp_Bindings(NULLPI, NULL); int save = PROTECT(nilExp); - LamExp *result = INVOKE(k, nilExp); + MinExp *result = INVOKE(k, nilExp); UNPROTECT(save); LEAVE(normalize_bindings); return result; @@ -262,28 +262,28 @@ static LamExp *normalize_bindings(LamBindings *bindings, AnfKont *k) { AnfKont *bindingsKont = makeKont_normalizeBindingsOuter(bindings->var, bindings->next, k); int save = PROTECT(bindingsKont); - LamExp *result = normalize(bindings->val, bindingsKont); + MinExp *result = normalize(bindings->val, bindingsKont); UNPROTECT(save); LEAVE(normalize_bindings); return result; } -static LamExp *normalizeBindingsOuterKont(LamExp *anfVal, +static MinExp *normalizeBindingsOuterKont(MinExp *anfVal, NormalizeBindingsOuterKontEnv *env) { AnfKont *k = makeKont_normalizeBindingsInner(env->x, anfVal, env->k); int save = PROTECT(k); - LamExp *result = normalize_bindings(env->rest, k); + MinExp *result = normalize_bindings(env->rest, k); UNPROTECT(save); return result; } -static LamExp *normalizeBindingsInnerKont(LamExp *anfrest, +static MinExp *normalizeBindingsInnerKont(MinExp *anfrest, NormalizeBindingsInnerKontEnv *env) { - LamBindings *rest = getLamExp_Bindings(anfrest); - LamExp *bindingsExp = - makeLamExp_Bindings(CPI(env->anfVal), env->x, env->anfVal, rest); + MinBindings *rest = getMinExp_Bindings(anfrest); + MinExp *bindingsExp = + makeMinExp_Bindings(CPI(env->anfVal), env->x, env->anfVal, rest); int save = PROTECT(bindingsExp); - LamExp *result = INVOKE(env->k, bindingsExp); + MinExp *result = INVOKE(env->k, bindingsExp); UNPROTECT(save); return result; } @@ -294,100 +294,23 @@ static LamExp *normalizeBindingsInnerKont(LamExp *anfrest, // `(letrec ,anfbindings // ,(normalize body k))]))) -static LamExp *normalize_LetRec(LamExp *exp, AnfKont *k) { +static MinExp *normalize_LetRec(MinExp *exp, AnfKont *k) { ENTER(normalize_LetRec); - LamLetRec *letrec = getLamExp_LetRec(exp); + MinLetRec *letrec = getMinExp_LetRec(exp); AnfKont *k1 = makeKont_normalizeLetRec(letrec->body, k); int save = PROTECT(k1); - LamExp *result = normalize_bindings(letrec->bindings, k1); + MinExp *result = normalize_bindings(letrec->bindings, k1); UNPROTECT(save); LEAVE(normalize_LetRec); return result; } -static LamExp *normalizeLetRecKont(LamExp *anfbindings, +static MinExp *normalizeLetRecKont(MinExp *anfbindings, NormalizeLetRecKontEnv *env) { - LamExp *body = normalize(env->body, env->k); - int save = PROTECT(body); - LamExp *result = makeLamExp_LetRec(CPI(env->body), - getLamExp_Bindings(anfbindings), body); - UNPROTECT(save); - return result; -} - -// (`(let ,bindings ,body) -// (normalize-bindings bindings -// [λ (anfbindings) -// `(let ,anfbindings -// ,(normalize body k))]))) - -static LamExp *normalize_Let(LamExp *exp, AnfKont *k) { - ENTER(normalize_Let); - AnfKont *k1 = makeKont_normalizeLet(getLamExp_Let(exp)->body, k); - int save = PROTECT(k1); - LamExp *result = normalize_bindings(getLamExp_Let(exp)->bindings, k1); - UNPROTECT(save); - LEAVE(normalize_Let); - return result; -} - -static LamExp *normalizeLetKont(LamExp *anfbindings, NormalizeLetKontEnv *env) { - LamExp *body = normalize(env->body, env->k); + MinExp *body = normalize(env->body, env->k); int save = PROTECT(body); - LamExp *result = - makeLamExp_Let(CPI(env->body), getLamExp_Bindings(anfbindings), body); - UNPROTECT(save); - return result; -} - -// (`(construct ,name ,tag . ,Ms) -// (normalize-names Ms -// [λ (ts) (k `(construct ,name ,tag . ,ts))])) - -static LamExp *normalize_Construct(LamExp *exp, AnfKont *k) { - ENTER(normalize_Construct); - LamConstruct *construct = getLamExp_Construct(exp); - AnfKont *k1 = - makeKont_normalizeConstruct(construct->name, construct->tag, k); - int save = PROTECT(k1); - LamExp *result = normalize_names(construct->args, k1); - UNPROTECT(save); - LEAVE(normalize_Construct); - return result; -} - -static LamExp *normalizeConstructKont(LamExp *ets, - NormalizeConstructKontEnv *env) { - LamArgs *ts = getLamExp_Args(ets); - LamExp *newConstruct = - makeLamExp_Construct(CPI(ets), env->name, env->tag, ts); - int save = PROTECT(newConstruct); - LamExp *result = INVOKE(env->k, newConstruct); - UNPROTECT(save); - return result; -} - -// (`(make-tuple . ,Ms) -// (normalize-names Ms -// [λ (ts) (k `(make-tuple . ,ts))])) - -static LamExp *normalize_MakeTuple(LamExp *exp, AnfKont *k) { - ENTER(normalize_MakeTuple); - LamArgs *lamArgs = getLamExp_MakeTuple(exp); - AnfKont *k2 = makeKont_normalizeMakeTuple(k); - int save = PROTECT(k2); - LamExp *result = normalize_names(lamArgs, k2); - UNPROTECT(save); - LEAVE(normalize_MakeTuple); - return result; -} - -static LamExp *normalizeMakeTupleKont(LamExp *ts, - NormalizeMakeTupleKontEnv *env) { - LamArgs *tts = getLamExp_Args(ts); - LamExp *newMakeTuple = newLamExp_MakeTuple(CPI(ts), tts); - int save = PROTECT(newMakeTuple); - LamExp *result = INVOKE(env->k, newMakeTuple); + MinExp *result = makeMinExp_LetRec(CPI(env->body), + getMinExp_Bindings(anfbindings), body); UNPROTECT(save); return result; } @@ -396,48 +319,22 @@ static LamExp *normalizeMakeTupleKont(LamExp *ts, // (normalize-names Ms // [λ (ts) (k `(make-vec ,nArgs . ,ts))])) -static LamExp *normalize_MakeVec(LamExp *exp, AnfKont *k) { +static MinExp *normalize_MakeVec(MinExp *exp, AnfKont *k) { ENTER(normalize_MakeVec); - LamMakeVec *makeVec = getLamExp_MakeVec(exp); - AnfKont *k2 = makeKont_normalizeMakeVec(makeVec->nArgs, k); + MinExprList *makeVec = getMinExp_MakeVec(exp); + AnfKont *k2 = makeKont_normalizeMakeVec(k); int save = PROTECT(k2); - LamExp *result = normalize_names(makeVec->args, k2); + MinExp *result = normalize_names(makeVec, k2); UNPROTECT(save); LEAVE(normalize_MakeVec); return result; } -static LamExp *normalizeMakeVecKont(LamExp *ts, NormalizeMakeVecKontEnv *env) { - LamArgs *tts = getLamExp_Args(ts); - LamExp *newMakeVec = makeLamExp_MakeVec(CPI(ts), env->nArgs, tts); +static MinExp *normalizeMakeVecKont(MinExp *ts, NormalizeMakeVecKontEnv *env) { + MinExprList *tts = getMinExp_Args(ts); + MinExp *newMakeVec = newMinExp_MakeVec(CPI(ts), tts); int save = PROTECT(newMakeVec); - LamExp *result = INVOKE(env->k, newMakeVec); - UNPROTECT(save); - return result; -} - -// (`(deconstruct ,name ,nsId ,vec ,e0) -// (normalize-name e0 -// [λ (t) (k `(deconstruct ,name ,nsId ,vec ,t))])) - -static LamExp *normalize_Deconstruct(LamExp *exp, AnfKont *k) { - ENTER(normalize_Deconstruct); - LamDeconstruct *deconstruct = getLamExp_Deconstruct(exp); - AnfKont *k2 = makeKont_normalizeDeconstruct( - deconstruct->name, deconstruct->nsId, deconstruct->vec, k); - int save = PROTECT(k2); - LamExp *result = normalize_name(deconstruct->exp, k2); - UNPROTECT(save); - LEAVE(normalize_Deconstruct); - return result; -} - -static LamExp *normalizeDeconstructKont(LamExp *t, - NormalizeDeconstructKontEnv *env) { - LamExp *newDeconstruct = - makeLamExp_Deconstruct(CPI(t), env->name, env->nsId, env->vec, t); - int save = PROTECT(newDeconstruct); - LamExp *result = INVOKE(env->k, newDeconstruct); + MinExp *result = INVOKE(env->k, newMakeVec); UNPROTECT(save); return result; } @@ -446,78 +343,78 @@ static LamExp *normalizeDeconstructKont(LamExp *t, // (normalize-name e0 // [λ (t) (k `(cond ,t ,(normalize-cases cases)))])) -static LamExp *normalize_Cond(LamExp *exp, AnfKont *k) { +static MinExp *normalize_Cond(MinExp *exp, AnfKont *k) { ENTER(normalize_Cond); - LamCond *cond = getLamExp_Cond(exp); + MinCond *cond = getMinExp_Cond(exp); AnfKont *k1 = makeKont_normalizeCond(cond->cases, k); int save = PROTECT(k1); - LamExp *result = normalize_name(cond->value, k1); + MinExp *result = normalize_name(cond->value, k1); UNPROTECT(save); LEAVE(normalize_Cond); return result; } -static LamCharCondCases *normalize_char_cases(LamCharCondCases *cases) { +static MinCharCondCases *normalize_char_cases(MinCharCondCases *cases) { if (cases == NULL) { return NULL; } - LamCharCondCases *rest = normalize_char_cases(cases->next); + MinCharCondCases *rest = normalize_char_cases(cases->next); int save = PROTECT(rest); - LamExp *newExp = normalize_term(cases->body); + MinExp *newExp = normalize_term(cases->body); PROTECT(newExp); - LamCharCondCases *newCases = - newLamCharCondCases(CPI(cases), cases->constant, newExp, rest); + MinCharCondCases *newCases = + newMinCharCondCases(CPI(cases), cases->constant, newExp, rest); UNPROTECT(save); return newCases; } -static LamIntCondCases *normalize_int_cases(LamIntCondCases *cases) { +static MinIntCondCases *normalize_int_cases(MinIntCondCases *cases) { if (cases == NULL) { return NULL; } - LamIntCondCases *rest = normalize_int_cases(cases->next); + MinIntCondCases *rest = normalize_int_cases(cases->next); int save = PROTECT(rest); - LamExp *newExp = normalize_term(cases->body); + MinExp *newExp = normalize_term(cases->body); PROTECT(newExp); - LamIntCondCases *newCases = - newLamIntCondCases(CPI(cases), cases->constant, newExp, rest); + MinIntCondCases *newCases = + newMinIntCondCases(CPI(cases), cases->constant, newExp, rest); UNPROTECT(save); return newCases; } -static LamCondCases *normalize_cases(LamCondCases *cases) { +static MinCondCases *normalize_cases(MinCondCases *cases) { if (cases == NULL) { return NULL; } switch (cases->type) { - case LAMCONDCASES_TYPE_CHARACTERS: { - LamCharCondCases *ccases = - normalize_char_cases(getLamCondCases_Characters(cases)); + case MINCONDCASES_TYPE_CHARACTERS: { + MinCharCondCases *ccases = + normalize_char_cases(getMinCondCases_Characters(cases)); int save = PROTECT(ccases); - LamCondCases *newCases = newLamCondCases_Characters(CPI(cases), ccases); + MinCondCases *newCases = newMinCondCases_Characters(CPI(cases), ccases); UNPROTECT(save); return newCases; } - case LAMCONDCASES_TYPE_INTEGERS: { - LamIntCondCases *icases = - normalize_int_cases(getLamCondCases_Integers(cases)); + case MINCONDCASES_TYPE_INTEGERS: { + MinIntCondCases *icases = + normalize_int_cases(getMinCondCases_Integers(cases)); int save = PROTECT(icases); - LamCondCases *newCases = newLamCondCases_Integers(CPI(cases), icases); + MinCondCases *newCases = newMinCondCases_Integers(CPI(cases), icases); UNPROTECT(save); return newCases; } default: - cant_happen("normalize_cases: unhandled LamCondCases type %s", - lamCondCasesTypeName(cases->type)); + cant_happen("normalize_cases: unhandled MinCondCases type %s", + minCondCasesTypeName(cases->type)); } } -static LamExp *normalizeCondKont(LamExp *t, NormalizeCondKontEnv *env) { - LamCondCases *cases = normalize_cases(env->cases); +static MinExp *normalizeCondKont(MinExp *t, NormalizeCondKontEnv *env) { + MinCondCases *cases = normalize_cases(env->cases); int save = PROTECT(cases); - LamExp *newCond = makeLamExp_Cond(CPI(t), t, cases); + MinExp *newCond = makeMinExp_Cond(CPI(t), t, cases); PROTECT(newCond); - LamExp *result = INVOKE(env->k, newCond); + MinExp *result = INVOKE(env->k, newCond); UNPROTECT(save); return result; } @@ -528,37 +425,37 @@ static LamExp *normalizeCondKont(LamExp *t, NormalizeCondKontEnv *env) { // (k `(match-expr ,t // ,(normalize-match-cases cases)))]))) -static LamExp *normalize_Match(LamExp *exp, AnfKont *k) { +static MinExp *normalize_Match(MinExp *exp, AnfKont *k) { ENTER(normalize_Match); - LamMatch *match = getLamExp_Match(exp); + MinMatch *match = getMinExp_Match(exp); AnfKont *k1 = makeKont_normalizeMatch(match->cases, k); int save = PROTECT(k1); - LamExp *result = normalize_name(match->index, k1); + MinExp *result = normalize_name(match->index, k1); UNPROTECT(save); LEAVE(normalize_Match); return result; } -static LamMatchList *normalize_match_cases(LamMatchList *cases) { +static MinMatchList *normalize_match_cases(MinMatchList *cases) { if (cases == NULL) { return NULL; } - LamMatchList *rest = normalize_match_cases(cases->next); + MinMatchList *rest = normalize_match_cases(cases->next); int save = PROTECT(rest); - LamExp *newExp = normalize_term(cases->body); + MinExp *newExp = normalize_term(cases->body); PROTECT(newExp); - LamMatchList *newCases = - newLamMatchList(CPI(cases), cases->matches, newExp, rest); + MinMatchList *newCases = + newMinMatchList(CPI(cases), cases->matches, newExp, rest); UNPROTECT(save); return newCases; } -static LamExp *normalizeMatchKont(LamExp *t, NormalizeMatchKontEnv *env) { - LamMatchList *cases = normalize_match_cases(env->cases); +static MinExp *normalizeMatchKont(MinExp *t, NormalizeMatchKontEnv *env) { + MinMatchList *cases = normalize_match_cases(env->cases); int save = PROTECT(cases); - LamExp *newMatch = makeLamExp_Match(CPI(t), t, cases); + MinExp *newMatch = makeMinExp_Match(CPI(t), t, cases); PROTECT(newMatch); - LamExp *result = INVOKE(env->k, newMatch); + MinExp *result = INVOKE(env->k, newMatch); UNPROTECT(save); return result; } @@ -570,128 +467,33 @@ static LamExp *normalizeMatchKont(LamExp *t, NormalizeMatchKontEnv *env) { // (λ (anfE2) // (k `(primitive-apply ,type ,anfE1 ,anfE2))))])) -static LamExp *normalize_PrimApp(LamExp *exp, AnfKont *k) { +static MinExp *normalize_PrimApp(MinExp *exp, AnfKont *k) { ENTER(normalize_PrimApp); - LamPrimApp *primApp = getLamExp_Prim(exp); + MinPrimApp *primApp = getMinExp_Prim(exp); AnfKont *k1 = makeKont_normalizePrimappOuter(primApp->type, primApp->exp2, k); int save = PROTECT(k1); - LamExp *result = normalize_name(primApp->exp1, k1); + MinExp *result = normalize_name(primApp->exp1, k1); UNPROTECT(save); LEAVE(normalize_PrimApp); return result; } -static LamExp *normalizePrimappOuterKont(LamExp *anfE0, +static MinExp *normalizePrimappOuterKont(MinExp *anfE0, NormalizePrimappOuterKontEnv *env) { AnfKont *k2 = makeKont_normalizePrimappInner(env->type, anfE0, env->k); int save = PROTECT(k2); - LamExp *result = normalize_name(env->e2, k2); + MinExp *result = normalize_name(env->e2, k2); UNPROTECT(save); return result; } -static LamExp *normalizePrimappInnerKont(LamExp *anfE2, +static MinExp *normalizePrimappInnerKont(MinExp *anfE2, NormalizePrimappInnerKontEnv *env) { - LamExp *newPrimApp = - makeLamExp_Prim(CPI(anfE2), env->type, env->anfE1, anfE2); + MinExp *newPrimApp = + makeMinExp_Prim(CPI(anfE2), env->type, env->anfE1, anfE2); int save = PROTECT(newPrimApp); - LamExp *result = INVOKE(env->k, newPrimApp); - UNPROTECT(save); - return result; -} - -// (`(print ,e0) -// (normalize-name e0 -// [λ (anfE0) (k `(print ,anfE0))])) - -static LamExp *normalize_Print(LamExp *exp, AnfKont *k) { - ENTER(normalize_Print); - LamPrint *printExp = getLamExp_Print(exp); - AnfKont *k1 = makeKont_normalizePrint(k); - int save = PROTECT(k1); - LamExp *result = normalize_name(printExp->exp, k1); - UNPROTECT(save); - LEAVE(normalize_Print); - return result; -} - -static LamExp *normalizePrintKont(LamExp *anfE0, NormalizePrintKontEnv *env) { - LamExp *newPrint = makeLamExp_Print(CPI(anfE0), anfE0); - int save = PROTECT(newPrint); - LamExp *result = INVOKE(env->k, newPrint); - UNPROTECT(save); - return result; -} - -// (`(typeOf ,e0) -// (normalize-name e0 -// [λ (anfE0) (k `(typeOf ,anfE0))])) - -static LamExp *normalize_TypeOf(LamExp *exp, AnfKont *k) { - ENTER(normalize_TypeOf); - LamTypeOf *typeOfExp = getLamExp_TypeOf(exp); - AnfKont *k2 = makeKont_normalizeTypeOf(k); - int save = PROTECT(k2); - LamExp *result = normalize_name(typeOfExp->exp, k2); - UNPROTECT(save); - LEAVE(normalize_TypeOf); - return result; -} - -static LamExp *normalizeTypeOfKont(LamExp *anfE0, NormalizeTypeOfKontEnv *env) { - LamExp *newTypeOf = makeLamExp_TypeOf(CPI(anfE0), anfE0); - int save = PROTECT(newTypeOf); - LamExp *result = INVOKE(env->k, newTypeOf); - UNPROTECT(save); - return result; -} - -// (`(tuple-index ,vec ,size ,e0) -// (normalize-name e0 -// [λ (t0) (k `(tuple-index ,vec ,size ,t0))])) - -static LamExp *normalize_TupleIndex(LamExp *exp, AnfKont *k) { - ENTER(normalize_TupleIndex); - LamTupleIndex *tupleIndexExp = getLamExp_TupleIndex(exp); - AnfKont *k2 = makeKont_normalizeTupleIndex(tupleIndexExp->vec, - tupleIndexExp->size, k); - int save = PROTECT(k2); - LamExp *result = normalize_name(tupleIndexExp->exp, k2); - UNPROTECT(save); - LEAVE(normalize_TupleIndex); - return result; -} - -static LamExp *normalizeTupleIndexKont(LamExp *t0, - NormalizeTupleIndexKontEnv *env) { - LamExp *newTupleIndex = - makeLamExp_TupleIndex(CPI(t0), env->vec, env->size, t0); - int save = PROTECT(newTupleIndex); - LamExp *result = INVOKE(env->k, newTupleIndex); - UNPROTECT(save); - return result; -} - -// (`(tag ,e0) -// (normalize-name e0 -// [λ (t0) (k `(tag ,t0))])) - -static LamExp *normalize_Tag(LamExp *exp, AnfKont *k) { - ENTER(normalize_Tag); - LamExp *tagExp = getLamExp_Tag(exp); - AnfKont *k2 = makeKont_normalizeTag(k); - int save = PROTECT(k2); - LamExp *result = normalize_name(tagExp, k2); - UNPROTECT(save); - LEAVE(normalize_Tag); - return result; -} - -static LamExp *normalizeTagKont(LamExp *t0, NormalizeTagKontEnv *env) { - LamExp *newTag = newLamExp_Tag(CPI(t0), t0); - int save = PROTECT(newTag); - LamExp *result = INVOKE(env->k, newTag); + MinExp *result = INVOKE(env->k, newPrimApp); UNPROTECT(save); return result; } @@ -700,16 +502,16 @@ static LamExp *normalizeTagKont(LamExp *t0, NormalizeTagKontEnv *env) { // (k `(amb ,(normalize-term e0) // ,(normalize-term e1)))) -static LamExp *normalize_Amb(LamExp *exp, AnfKont *k) { +static MinExp *normalize_Amb(MinExp *exp, AnfKont *k) { ENTER(normalize_Amb); - LamAmb *ambExp = getLamExp_Amb(exp); - LamExp *e0 = normalize_term(ambExp->left); + MinAmb *ambExp = getMinExp_Amb(exp); + MinExp *e0 = normalize_term(ambExp->left); int save = PROTECT(e0); - LamExp *e1 = normalize_term(ambExp->right); + MinExp *e1 = normalize_term(ambExp->right); PROTECT(e1); - LamExp *newAmb = makeLamExp_Amb(CPI(exp), e0, e1); + MinExp *newAmb = makeMinExp_Amb(CPI(exp), e0, e1); PROTECT(newAmb); - LamExp *result = INVOKE(k, newAmb); + MinExp *result = INVOKE(k, newAmb); UNPROTECT(save); LEAVE(normalize_Amb); return result; @@ -718,15 +520,14 @@ static LamExp *normalize_Amb(LamExp *exp, AnfKont *k) { // (`(λ ,params ,body) // (k `(λ ,params ,(normalize-term body)))) -static LamExp *normalize_Lam(LamExp *exp, AnfKont *k) { +static MinExp *normalize_Lam(MinExp *exp, AnfKont *k) { ENTER(normalize_Lam); - LamLam *lamExp = getLamExp_Lam(exp); - LamExp *newBody = normalize_term(lamExp->exp); + MinLam *minExp = getMinExp_Lam(exp); + MinExp *newBody = normalize_term(minExp->exp); int save = PROTECT(newBody); - LamExp *newLam = makeLamExp_Lam(CPI(exp), lamExp->args, newBody); - PROTECT(newLam); - getLamExp_Lam(newLam)->isMacro = lamExp->isMacro; - LamExp *result = INVOKE(k, newLam); + MinExp *newMin = makeMinExp_Lam(CPI(exp), minExp->args, newBody); + PROTECT(newMin); + MinExp *result = INVOKE(k, newMin); UNPROTECT(save); LEAVE(normalize_Lam); return result; @@ -735,15 +536,14 @@ static LamExp *normalize_Lam(LamExp *exp, AnfKont *k) { // (`(lookUp ,name ,id ,expr) // (k `(lookUp ,name ,id ,(normalize-term expr)))) -static LamExp *normalize_LookUp(LamExp *exp, AnfKont *k) { +static MinExp *normalize_LookUp(MinExp *exp, AnfKont *k) { ENTER(normalize_LookUp); - LamLookUp *lookUpExp = getLamExp_LookUp(exp); - LamExp *newExpr = normalize_term(lookUpExp->exp); + MinLookUp *lookUpExp = getMinExp_LookUp(exp); + MinExp *newExpr = normalize_term(lookUpExp->exp); int save = PROTECT(newExpr); - LamExp *newLookUp = makeLamExp_LookUp(CPI(exp), lookUpExp->nsId, - lookUpExp->nsSymbol, newExpr); + MinExp *newLookUp = makeMinExp_LookUp(CPI(exp), lookUpExp->nsId, newExpr); PROTECT(newLookUp); - LamExp *result = INVOKE(k, newLookUp); + MinExp *result = INVOKE(k, newLookUp); UNPROTECT(save); LEAVE(normalize_LookUp); return result; @@ -752,26 +552,26 @@ static LamExp *normalize_LookUp(LamExp *exp, AnfKont *k) { // (`(nameSpaces . ,Ms) // (k `(nameSpaces . ,(normalize-terms Ms)))) -static LamNameSpaceArray *normalize_array(LamNameSpaceArray *nsArray) { - LamNameSpaceArray *newNsArray = newLamNameSpaceArray(); +static MinNameSpaceArray *normalize_array(MinNameSpaceArray *nsArray) { + MinNameSpaceArray *newNsArray = newMinNameSpaceArray(); int save = PROTECT(newNsArray); for (Index i = 0; i < nsArray->size; i++) { - LamExp *normNs = normalize_term(nsArray->entries[i]); + MinExp *normNs = normalize_term(nsArray->entries[i]); int save = PROTECT(normNs); - pushLamNameSpaceArray(newNsArray, normNs); + pushMinNameSpaceArray(newNsArray, normNs); UNPROTECT(save); } UNPROTECT(save); return newNsArray; } -static LamExp *normalize_NameSpaces(LamExp *exp, AnfKont *k) { +static MinExp *normalize_NameSpaces(MinExp *exp, AnfKont *k) { ENTER(normalize_NameSpaces); - LamNameSpaceArray *nsExp = normalize_array(getLamExp_NameSpaces(exp)); + MinNameSpaceArray *nsExp = normalize_array(getMinExp_NameSpaces(exp)); int save = PROTECT(nsExp); - LamExp *newNsExp = newLamExp_NameSpaces(CPI(exp), nsExp); + MinExp *newNsExp = newMinExp_NameSpaces(CPI(exp), nsExp); PROTECT(newNsExp); - LamExp *result = INVOKE(k, newNsExp); + MinExp *result = INVOKE(k, newNsExp); ; UNPROTECT(save); LEAVE(normalize_NameSpaces); @@ -782,21 +582,21 @@ static LamExp *normalize_NameSpaces(LamExp *exp, AnfKont *k) { // (normalize-name e0 // [λ (t0) (k `(callcc ,t0))])) -static LamExp *normalize_CallCC(LamExp *exp, AnfKont *k) { +static MinExp *normalize_CallCC(MinExp *exp, AnfKont *k) { ENTER(normalize_CallCC); - LamExp *e0 = getLamExp_CallCC(exp); + MinExp *e0 = getMinExp_CallCC(exp); AnfKont *k2 = makeKont_normalizeCallCC(k); int save = PROTECT(k2); - LamExp *result = normalize_name(e0, k2); + MinExp *result = normalize_name(e0, k2); UNPROTECT(save); LEAVE(normalize_CallCC); return result; } -static LamExp *normalizeCallCCKont(LamExp *t0, NormalizeCallCCKontEnv *env) { - LamExp *newCallCC = newLamExp_CallCC(CPI(t0), t0); +static MinExp *normalizeCallCCKont(MinExp *t0, NormalizeCallCCKontEnv *env) { + MinExp *newCallCC = newMinExp_CallCC(CPI(t0), t0); int save = PROTECT(newCallCC); - LamExp *result = INVOKE(env->k, newCallCC); + MinExp *result = INVOKE(env->k, newCallCC); UNPROTECT(save); return result; } @@ -804,131 +604,87 @@ static LamExp *normalizeCallCCKont(LamExp *t0, NormalizeCallCCKontEnv *env) { // (`(sequence . ,Ms) // (k `(sequence . ,(normalize-terms Ms)))) -static LamSequence *_normalizeSquence(LamSequence *seq); +static MinExprList *_normalizeSquence(MinExprList *seq); -static LamExp *normalize_Sequence(LamExp *exp, AnfKont *k) { +static MinExp *normalize_Sequence(MinExp *exp, AnfKont *k) { ENTER(normalize_Sequence); - LamSequence *normSeq = _normalizeSquence(getLamExp_Sequence(exp)); + MinExprList *normSeq = _normalizeSquence(getMinExp_Sequence(exp)); int save = PROTECT(normSeq); - LamExp *newSeqExp = newLamExp_Sequence(CPI(exp), normSeq); + MinExp *newSeqExp = newMinExp_Sequence(CPI(exp), normSeq); PROTECT(newSeqExp); - LamExp *result = INVOKE(k, newSeqExp); + MinExp *result = INVOKE(k, newSeqExp); UNPROTECT(save); LEAVE(normalize_Sequence); return result; } -static LamSequence *_normalizeSquence(LamSequence *seq) { +static MinExprList *_normalizeSquence(MinExprList *seq) { if (seq == NULL) return NULL; - LamSequence *rest = _normalizeSquence(seq->next); + MinExprList *rest = _normalizeSquence(seq->next); int save = PROTECT(rest); - LamExp *newExp = normalize_term(seq->exp); + MinExp *newExp = normalize_term(seq->exp); PROTECT(newExp); - LamSequence *newSeq = newLamSequence(CPI(seq), newExp, rest); + MinExprList *newSeq = newMinExprList(CPI(seq), newExp, rest); UNPROTECT(save); return newSeq; } -// (`(typeDefs ,defs ,body) -// (k `(typeDefs ,defs ,(normalize-term body)))) - -static LamExp *normalize_TypeDefs(LamExp *exp, AnfKont *k) { - ENTER(normalize_TypeDefs); - LamTypeDefs *typeDefsExp = getLamExp_TypeDefs(exp); - LamExp *newBody = normalize_term(typeDefsExp->body); - int save = PROTECT(newBody); - LamExp *newTypeDefs = - makeLamExp_TypeDefs(CPI(exp), typeDefsExp->typeDefs, newBody); - PROTECT(newTypeDefs); - LamExp *result = INVOKE(k, newTypeDefs); - UNPROTECT(save); - LEAVE(normalize_TypeDefs); - return result; -} - // (define (normalize e k) // (match e // ...)) -static LamExp *normalize(LamExp *exp, AnfKont *k) { +static MinExp *normalize(MinExp *exp, AnfKont *k) { ENTER(normalize); - LamExp *res = NULL; + MinExp *res = NULL; if (exp == NULL) { res = NULL; } else if (isValueExp(exp)) { res = INVOKE(k, exp); } else { switch (exp->type) { - case LAMEXP_TYPE_AMB: + case MINEXP_TYPE_AMB: res = normalize_Amb(exp, k); break; - case LAMEXP_TYPE_APPLY: + case MINEXP_TYPE_APPLY: res = normalize_Apply(exp, k); break; - case LAMEXP_TYPE_CALLCC: + case MINEXP_TYPE_CALLCC: res = normalize_CallCC(exp, k); break; - case LAMEXP_TYPE_COND: + case MINEXP_TYPE_COND: res = normalize_Cond(exp, k); break; - case LAMEXP_TYPE_CONSTRUCT: - res = normalize_Construct(exp, k); - break; - case LAMEXP_TYPE_DECONSTRUCT: - res = normalize_Deconstruct(exp, k); - break; - case LAMEXP_TYPE_IFF: + case MINEXP_TYPE_IFF: res = normalize_Iff(exp, k); break; - case LAMEXP_TYPE_LAM: + case MINEXP_TYPE_LAM: res = normalize_Lam(exp, k); break; - case LAMEXP_TYPE_LETREC: + case MINEXP_TYPE_LETREC: res = normalize_LetRec(exp, k); break; - case LAMEXP_TYPE_LET: - res = normalize_Let(exp, k); - break; - case LAMEXP_TYPE_LOOKUP: + case MINEXP_TYPE_LOOKUP: res = normalize_LookUp(exp, k); break; - case LAMEXP_TYPE_MAKETUPLE: - res = normalize_MakeTuple(exp, k); - break; - case LAMEXP_TYPE_MAKEVEC: + case MINEXP_TYPE_MAKEVEC: res = normalize_MakeVec(exp, k); break; - case LAMEXP_TYPE_MATCH: + case MINEXP_TYPE_MATCH: res = normalize_Match(exp, k); break; - case LAMEXP_TYPE_NAMESPACES: + case MINEXP_TYPE_NAMESPACES: res = normalize_NameSpaces(exp, k); break; - case LAMEXP_TYPE_PRIM: + case MINEXP_TYPE_PRIM: res = normalize_PrimApp(exp, k); break; - case LAMEXP_TYPE_PRINT: - res = normalize_Print(exp, k); - break; - case LAMEXP_TYPE_SEQUENCE: + case MINEXP_TYPE_SEQUENCE: res = normalize_Sequence(exp, k); break; - case LAMEXP_TYPE_TAG: - res = normalize_Tag(exp, k); - break; - case LAMEXP_TYPE_TUPLEINDEX: - res = normalize_TupleIndex(exp, k); - break; - case LAMEXP_TYPE_TYPEDEFS: - res = normalize_TypeDefs(exp, k); - break; - case LAMEXP_TYPE_TYPEOF: - res = normalize_TypeOf(exp, k); - break; default: - cant_happen("normalize: unhandled LamExp type %s", - lamExpTypeName(exp->type)); + cant_happen("normalize: unhandled MinExp type %s", + minExpTypeName(exp->type)); } } LEAVE(normalize); @@ -938,4 +694,4 @@ static LamExp *normalize(LamExp *exp, AnfKont *k) { /** * Public entry point. */ -LamExp *anfNormalize2(LamExp *exp) { return normalize_term(exp); } +MinExp *anfNormalize2(MinExp *exp) { return normalize_term(exp); } diff --git a/src/anf_pp.c b/src/anf_pp.c index 9be8fa21..47cf47bc 100644 --- a/src/anf_pp.c +++ b/src/anf_pp.c @@ -21,9 +21,10 @@ #include #include -#include "common.h" #include "anf_pp.h" +#include "common.h" #include "hash.h" +#include "utils.h" void ppAnfEnv(AnfEnv *env) { eprintf("[\n"); @@ -34,7 +35,7 @@ void ppAnfEnv(AnfEnv *env) { Index i = 0; HashSymbol *key; int value; - while ((key = iterateAnfIntTable(env->table, &i, &value)) != NULL) { + while ((key = iterateIntMap(env->table, &i, &value)) != NULL) { eprintf("%s: %d\n", key->name, value); } ppAnfEnv(env->next); @@ -62,24 +63,22 @@ void ppAexpVarList(AexpVarList *x) { } static void ppChar(char c) { - switch(c) { - case '\n': - eprintf("\"\\n\""); - break; - case '\t': - eprintf("\"\\t\""); - break; - case '\"': - eprintf("\"\\\"\""); - break; - default: - eprintf("\"%c\"", c); + switch (c) { + case '\n': + eprintf("\"\\n\""); + break; + case '\t': + eprintf("\"\\t\""); + break; + case '\"': + eprintf("\"\\\"\""); + break; + default: + eprintf("\"%c\"", c); } } -void ppAexpVar(HashSymbol *x) { - eprintf("%s", x->name); -} +void ppAexpVar(HashSymbol *x) { eprintf("%s", x->name); } void ppAexpAnnotatedVar(AexpAnnotatedVar *x) { // ppAexpVar(x->var); @@ -92,50 +91,50 @@ void ppAexpAnnotatedVar(AexpAnnotatedVar *x) { void ppAexpPrimApp(AexpPrimApp *x) { eprintf("("); switch (x->type) { - case AEXPPRIMOP_TYPE_ADD: - eprintf("add "); - break; - case AEXPPRIMOP_TYPE_SUB: - eprintf("sub "); - break; - case AEXPPRIMOP_TYPE_MUL: - eprintf("mul "); - break; - case AEXPPRIMOP_TYPE_DIV: - eprintf("div "); - break; - case AEXPPRIMOP_TYPE_EQ: - eprintf("eq "); - break; - case AEXPPRIMOP_TYPE_NE: - eprintf("ne "); - break; - case AEXPPRIMOP_TYPE_GT: - eprintf("gt "); - break; - case AEXPPRIMOP_TYPE_LT: - eprintf("lt "); - break; - case AEXPPRIMOP_TYPE_GE: - eprintf("ge "); - break; - case AEXPPRIMOP_TYPE_LE: - eprintf("le "); - break; - case AEXPPRIMOP_TYPE_VEC: - eprintf("vec "); - break; - case AEXPPRIMOP_TYPE_MOD: - eprintf("mod "); - break; - case AEXPPRIMOP_TYPE_CMP: - eprintf("cmp "); - break; - case AEXPPRIMOP_TYPE_POW: - eprintf("pow "); - break; - default: - cant_happen("unrecognized op %s", aexpPrimOpName(x->type)); + case AEXPPRIMOP_TYPE_ADD: + eprintf("add "); + break; + case AEXPPRIMOP_TYPE_SUB: + eprintf("sub "); + break; + case AEXPPRIMOP_TYPE_MUL: + eprintf("mul "); + break; + case AEXPPRIMOP_TYPE_DIV: + eprintf("div "); + break; + case AEXPPRIMOP_TYPE_EQ: + eprintf("eq "); + break; + case AEXPPRIMOP_TYPE_NE: + eprintf("ne "); + break; + case AEXPPRIMOP_TYPE_GT: + eprintf("gt "); + break; + case AEXPPRIMOP_TYPE_LT: + eprintf("lt "); + break; + case AEXPPRIMOP_TYPE_GE: + eprintf("ge "); + break; + case AEXPPRIMOP_TYPE_LE: + eprintf("le "); + break; + case AEXPPRIMOP_TYPE_VEC: + eprintf("vec "); + break; + case AEXPPRIMOP_TYPE_MOD: + eprintf("mod "); + break; + case AEXPPRIMOP_TYPE_CMP: + eprintf("cmp "); + break; + case AEXPPRIMOP_TYPE_POW: + eprintf("pow "); + break; + default: + cant_happen("unrecognized op %s", aexpPrimOpName(x->type)); } ppAexp(x->exp1); if (x->exp2 != NULL) { @@ -274,14 +273,14 @@ void ppCexpCharCondCases(CexpCharCondCases *x) { void ppCexpCondCases(CexpCondCases *x) { switch (x->type) { - case CEXPCONDCASES_TYPE_INTCASES: - ppCexpIntCondCases(x->val.intCases); - break; - case CEXPCONDCASES_TYPE_CHARCASES: - ppCexpCharCondCases(x->val.charCases); - break; - default: - cant_happen("unrecognised type %d in ppCexpCondCases", x->type); + case CEXPCONDCASES_TYPE_INTCASES: + ppCexpIntCondCases(x->val.intCases); + break; + case CEXPCONDCASES_TYPE_CHARCASES: + ppCexpCharCondCases(x->val.charCases); + break; + default: + cant_happen("unrecognised type %d in ppCexpCondCases", x->type); } } @@ -353,100 +352,100 @@ void ppAnfExpLookUp(AnfExpLookUp *x) { void ppAexp(Aexp *x) { switch (x->type) { - case AEXP_TYPE_LAM: - ppAexpLam(x->val.lam); - break; - case AEXP_TYPE_VAR: - ppAexpVar(x->val.var); - break; - case AEXP_TYPE_ANNOTATEDVAR: - ppAexpAnnotatedVar(x->val.annotatedVar); - break; - case AEXP_TYPE_BIGINTEGER: - fprintMaybeBigInt(errout, x->val.bigInteger); - break; - case AEXP_TYPE_LITTLEINTEGER: - eprintf("%d", x->val.littleInteger); - break; - case AEXP_TYPE_CHARACTER: - ppChar(x->val.character); - break; - case AEXP_TYPE_PRIM: - ppAexpPrimApp(x->val.prim); - break; - case AEXP_TYPE_MAKEVEC: - ppAexpMakeVec(x->val.makeVec); - break; - case AEXP_TYPE_NAMESPACES: - ppAexpNameSpaces(x->val.nameSpaces); - break; - default: - cant_happen("unrecognised aexp %s", aexpTypeName(x->type)); + case AEXP_TYPE_LAM: + ppAexpLam(x->val.lam); + break; + case AEXP_TYPE_VAR: + ppAexpVar(x->val.var); + break; + case AEXP_TYPE_ANNOTATEDVAR: + ppAexpAnnotatedVar(x->val.annotatedVar); + break; + case AEXP_TYPE_BIGINTEGER: + fprintMaybeBigInt(errout, x->val.bigInteger); + break; + case AEXP_TYPE_LITTLEINTEGER: + eprintf("%d", x->val.littleInteger); + break; + case AEXP_TYPE_CHARACTER: + ppChar(x->val.character); + break; + case AEXP_TYPE_PRIM: + ppAexpPrimApp(x->val.prim); + break; + case AEXP_TYPE_MAKEVEC: + ppAexpMakeVec(x->val.makeVec); + break; + case AEXP_TYPE_NAMESPACES: + ppAexpNameSpaces(x->val.nameSpaces); + break; + default: + cant_happen("unrecognised aexp %s", aexpTypeName(x->type)); } } void ppCexp(Cexp *x) { switch (x->type) { - case CEXP_TYPE_APPLY: - ppCexpApply(x->val.apply); - break; - case CEXP_TYPE_IFF: - ppCexpIf(x->val.iff); - break; - case CEXP_TYPE_COND: - ppCexpCond(x->val.cond); - break; - case CEXP_TYPE_CALLCC: - eprintf("(call/cc "); - ppAexp(x->val.callCC); - eprintf(")"); - break; - case CEXP_TYPE_LETREC: - ppCexpLetRec(x->val.letRec); - break; - case CEXP_TYPE_AMB: - ppCexpAmb(x->val.amb); - break; - case CEXP_TYPE_CUT: - ppCexpCut(x->val.cut); - break; - case CEXP_TYPE_MATCH: - ppCexpMatch(x->val.match); - break; - case CEXP_TYPE_BACK: - eprintf("(back)"); - break; - case CEXP_TYPE_ERROR: - eprintf("(error)"); - break; - default: - cant_happen("unrecognised cexp %d in ppCexp", x->type); + case CEXP_TYPE_APPLY: + ppCexpApply(x->val.apply); + break; + case CEXP_TYPE_IFF: + ppCexpIf(x->val.iff); + break; + case CEXP_TYPE_COND: + ppCexpCond(x->val.cond); + break; + case CEXP_TYPE_CALLCC: + eprintf("(call/cc "); + ppAexp(x->val.callCC); + eprintf(")"); + break; + case CEXP_TYPE_LETREC: + ppCexpLetRec(x->val.letRec); + break; + case CEXP_TYPE_AMB: + ppCexpAmb(x->val.amb); + break; + case CEXP_TYPE_CUT: + ppCexpCut(x->val.cut); + break; + case CEXP_TYPE_MATCH: + ppCexpMatch(x->val.match); + break; + case CEXP_TYPE_BACK: + eprintf("(back)"); + break; + case CEXP_TYPE_ERROR: + eprintf("(error)"); + break; + default: + cant_happen("unrecognised cexp %d in ppCexp", x->type); } } void ppAnfExp(AnfExp *x) { switch (x->type) { - case ANFEXP_TYPE_AEXP: - ppAexp(x->val.aexp); - break; - case ANFEXP_TYPE_CEXP: - ppCexp(x->val.cexp); - break; - case ANFEXP_TYPE_LET: - ppAnfExpLet(x->val.let); - break; - case ANFEXP_TYPE_DONE: - eprintf(""); - break; - case ANFEXP_TYPE_ENV: - eprintf("ENV"); - break; - case ANFEXP_TYPE_LOOKUP: - ppAnfExpLookUp(x->val.lookUp); - break; - default: - eprintf("", anfExpTypeName(x->type)); - exit(1); + case ANFEXP_TYPE_AEXP: + ppAexp(x->val.aexp); + break; + case ANFEXP_TYPE_CEXP: + ppCexp(x->val.cexp); + break; + case ANFEXP_TYPE_LET: + ppAnfExpLet(x->val.let); + break; + case ANFEXP_TYPE_DONE: + eprintf(""); + break; + case ANFEXP_TYPE_ENV: + eprintf("ENV"); + break; + case ANFEXP_TYPE_LOOKUP: + ppAnfExpLookUp(x->val.lookUp); + break; + default: + eprintf("", anfExpTypeName(x->type)); + exit(1); } } diff --git a/src/annotate.c b/src/annotate.c index e58cbaa5..b3296adb 100644 --- a/src/annotate.c +++ b/src/annotate.c @@ -22,18 +22,19 @@ #include #include -#include "common.h" -#include "annotate.h" #include "anf.h" #include "anf_pp.h" -#include "types.h" -#include "symbol.h" +#include "annotate.h" +#include "common.h" #include "lambda_helper.h" +#include "symbol.h" +#include "types.h" +#include "utils.h" #ifdef DEBUG_ANNOTATE -# include "debug.h" -# include "anf_debug.h" -# include "anf_pp.h" +#include "anf_debug.h" +#include "anf_pp.h" +#include "debug.h" #endif static bool locate(HashSymbol *var, AnfEnv *env, int *frame, int *offset); @@ -41,7 +42,8 @@ static void populateAnfEnv(AnfEnv *env, HashSymbol *var); static AnfEnv *annotateExp(AnfExp *x, AnfEnv *env); static AnfEnv *annotateAexpLam(AexpLam *x, AnfEnv *env); -static AexpAnnotatedVar *annotateAexpVar(ParserInfo I, HashSymbol *x, AnfEnv *env); +static AexpAnnotatedVar *annotateAexpVar(ParserInfo I, HashSymbol *x, + AnfEnv *env); static AnfEnv *annotateAexpPrimApp(AexpPrimApp *x, AnfEnv *env); static AnfEnv *annotateAexpList(AexpList *x, AnfEnv *env); static AnfEnv *annotateCexpApply(CexpApply *x, AnfEnv *env); @@ -56,9 +58,9 @@ static AnfEnv *annotateAexp(Aexp *x, AnfEnv *env); static AnfEnv *annotateCexp(Cexp *x, AnfEnv *env); static AnfEnvArray *getNsEnvs(AnfEnv *env); -static void hashAddCTVar(AnfIntTable *table, HashSymbol *var) { - int count = countAnfIntTable(table); - setAnfIntTable(table, var, count); +static void hashAddCTVar(IntMap *table, HashSymbol *var) { + int count = countIntMap(table); + setIntMap(table, var, count); } static AnfEnv *annotateAexpLam(AexpLam *x, AnfEnv *env) { @@ -78,12 +80,13 @@ static AnfEnv *annotateAexpLam(AexpLam *x, AnfEnv *env) { populateAnfEnv(env, args->var); args = args->next; } - annotateExp(x->exp, env); + AnfEnv *env2 = annotateExp(x->exp, env); UNPROTECT(save); - return env; + return env2->isCapturing ? env2 : env; } -static AexpAnnotatedVar *annotateAexpVar(ParserInfo I, HashSymbol *x, AnfEnv *env) { +static AexpAnnotatedVar *annotateAexpVar(ParserInfo I, HashSymbol *x, + AnfEnv *env) { #ifdef DEBUG_ANNOTATE2 eprintf("annotateAexpVar "); ppAexpVar(x); @@ -95,14 +98,15 @@ static AexpAnnotatedVar *annotateAexpVar(ParserInfo I, HashSymbol *x, AnfEnv *en int offset; if (locate(x, env, &frame, &offset)) { if (frame == 0) { - return newAexpAnnotatedVar(I, AEXPANNOTATEDVARTYPE_TYPE_STACK, frame, - offset, x); + return newAexpAnnotatedVar(I, AEXPANNOTATEDVARTYPE_TYPE_STACK, + frame, offset, x); } else { return newAexpAnnotatedVar(I, AEXPANNOTATEDVARTYPE_TYPE_ENV, frame - 1, offset, x); } } - cant_happen("no binding for var '%s' in annotateAexpVar [%s +%d]", x->name, I.fileName, I.lineNo); + cant_happen("no binding for var '%s' in annotateAexpVar [%s +%d]", x->name, + I.fileName, I.lineNo); } static AnfEnv *annotateAexpPrimApp(AexpPrimApp *x, AnfEnv *env) { @@ -142,9 +146,11 @@ static AnfEnv *annotateCexpApply(CexpApply *x, AnfEnv *env) { ppAnfEnv(env); eprintf("\n"); #endif - annotateAexp(x->function, env); + AnfEnv *env2 = annotateAexp(x->function, env); + int save = PROTECT(env2); annotateAexpList(x->args, env); - return env; + UNPROTECT(save); + return env2->isCapturing ? env2 : env; } static AnfEnv *annotateCexpIf(CexpIf *x, AnfEnv *env) { @@ -201,31 +207,29 @@ static AnfEnv *annotateCexpCondCases(CexpCondCases *x, AnfEnv *env) { eprintf("\n"); #endif switch (x->type) { - case CEXPCONDCASES_TYPE_INTCASES: - return annotateCexpIntCondCases(x->val.intCases, env); - case CEXPCONDCASES_TYPE_CHARCASES: - return annotateCexpCharCondCases(x->val.charCases, env); - default: - cant_happen("unrecognised type %d in annotateCexpCondCases", - x->type); + case CEXPCONDCASES_TYPE_INTCASES: + return annotateCexpIntCondCases(x->val.intCases, env); + case CEXPCONDCASES_TYPE_CHARCASES: + return annotateCexpCharCondCases(x->val.charCases, env); + default: + cant_happen("unrecognised type %d in annotateCexpCondCases", x->type); } } static AnfEnv *annotateLetRecLam(Aexp *x, AnfEnv *env, int letRecOffset) { switch (x->type) { - case AEXP_TYPE_LAM: { - AexpLam *lam = x->val.lam; - annotateAexpLam(lam, env); - lam->letRecOffset = letRecOffset; - } - break; - case AEXP_TYPE_VAR: { - x->type = AEXP_TYPE_ANNOTATEDVAR; - x->val.annotatedVar = annotateAexpVar(CPI(x), x->val.var, env); - } - break; - default: - cant_happen("letrec bindings can only contain lambdas, got %s", aexpTypeName(x->type)); + case AEXP_TYPE_LAM: { + AexpLam *lam = x->val.lam; + annotateAexpLam(lam, env); + lam->letRecOffset = letRecOffset; + } break; + case AEXP_TYPE_VAR: { + x->type = AEXP_TYPE_ANNOTATEDVAR; + x->val.annotatedVar = annotateAexpVar(CPI(x), x->val.var, env); + } break; + default: + cant_happen("letrec bindings can only contain lambdas, got %s", + aexpTypeName(x->type)); } return env; } @@ -248,7 +252,8 @@ static AnfEnv *annotateCexpLetRec(CexpLetRec *x, AnfEnv *env) { bindings = bindings->next; } bindings = x->bindings; - for (int letRecOffset = 0; bindings != NULL; bindings = bindings->next, letRecOffset++) { + for (int letRecOffset = 0; bindings != NULL; + bindings = bindings->next, letRecOffset++) { annotateLetRecLam(bindings->val, env, letRecOffset); } annotateExp(x->body, env); @@ -318,19 +323,20 @@ static HashSymbol *makeNsName(Index index) { return newSymbol(buf); } -static AnfEnv *annotateAexpNameSpaceArray(AexpNameSpaceArray *x, AnfEnv *env) { - AnfEnvArray *nsEnvs = getNsEnvs(env); - for (Index i = 0; i < x->size; ++i) { +static AnfEnv *annotateAexpNameSpaceArray(AexpNameSpaceArray *nsa, + AnfEnv *env) { + for (Index i = 0; i < nsa->size; ++i) { HashSymbol *nsName = makeNsName(i); populateAnfEnv(env, nsName); } - for (Index i = 0; i < x->size; ++i) { - AnfEnv *env2 = newAnfEnv(CPI(x->entries[i]->body), true, env); + AnfEnvArray *nsEnvs = getNsEnvs(env); + for (Index i = 0; i < nsa->size; ++i) { + AnfEnv *env2 = newAnfEnv(CPI(nsa->entries[i]->body), true, env); int save = PROTECT(env2); env2->isNameSpace = true; - AnfEnv *env3 = annotateExp(x->entries[i]->body, env2); + AnfEnv *env3 = annotateExp(nsa->entries[i]->body, env2); PROTECT(env3); - x->entries[i]->nBindings = env2->nBindings; + nsa->entries[i]->nBindings = env2->nBindings; pushAnfEnvArray(nsEnvs, env3); UNPROTECT(save); } @@ -364,27 +370,28 @@ static AnfEnv *annotateAexp(Aexp *x, AnfEnv *env) { eprintf("\n"); #endif switch (x->type) { - case AEXP_TYPE_LAM: - return annotateAexpLam(x->val.lam, env); - case AEXP_TYPE_VAR: - x->val.annotatedVar = annotateAexpVar(CPI(x), x->val.var, env); - x->type = AEXP_TYPE_ANNOTATEDVAR; - return env; - case AEXP_TYPE_ANNOTATEDVAR: - cant_happen("annotateAexp called on annotated var %s", - x->val.annotatedVar->var->name); - case AEXP_TYPE_BIGINTEGER: - case AEXP_TYPE_LITTLEINTEGER: - case AEXP_TYPE_CHARACTER: - return env; - case AEXP_TYPE_PRIM: - return annotateAexpPrimApp(x->val.prim, env); - case AEXP_TYPE_MAKEVEC: - return annotateAexpMakeVec(x->val.makeVec, env); - case AEXP_TYPE_NAMESPACES: - return annotateAexpNameSpaces(x->val.nameSpaces, env); - default: - cant_happen("unrecognized type %s in annotateAexp", aexpTypeName(x->type)); + case AEXP_TYPE_LAM: + return annotateAexpLam(x->val.lam, env); + case AEXP_TYPE_VAR: + x->val.annotatedVar = annotateAexpVar(CPI(x), x->val.var, env); + x->type = AEXP_TYPE_ANNOTATEDVAR; + return env; + case AEXP_TYPE_ANNOTATEDVAR: + cant_happen("annotateAexp called on annotated var %s", + x->val.annotatedVar->var->name); + case AEXP_TYPE_BIGINTEGER: + case AEXP_TYPE_LITTLEINTEGER: + case AEXP_TYPE_CHARACTER: + return env; + case AEXP_TYPE_PRIM: + return annotateAexpPrimApp(x->val.prim, env); + case AEXP_TYPE_MAKEVEC: + return annotateAexpMakeVec(x->val.makeVec, env); + case AEXP_TYPE_NAMESPACES: + return annotateAexpNameSpaces(x->val.nameSpaces, env); + default: + cant_happen("unrecognized type %s in annotateAexp", + aexpTypeName(x->type)); } } @@ -425,35 +432,36 @@ static AnfEnv *annotateCexp(Cexp *x, AnfEnv *env) { eprintf("\n"); #endif switch (x->type) { - case CEXP_TYPE_APPLY: - return annotateCexpApply(x->val.apply, env); - case CEXP_TYPE_IFF: - return annotateCexpIf(x->val.iff, env); - case CEXP_TYPE_COND: - return annotateCexpCond(x->val.cond, env); - case CEXP_TYPE_CALLCC: - return annotateAexp(x->val.callCC, env); - case CEXP_TYPE_LETREC: - return annotateCexpLetRec(x->val.letRec, env); - case CEXP_TYPE_AMB: - return annotateCexpAmb(x->val.amb, env); - case CEXP_TYPE_CUT: - return annotateCexpCut(x->val.cut, env); - case CEXP_TYPE_MATCH: - return annotateCexpMatch(x->val.match, env); - case CEXP_TYPE_BACK: - case CEXP_TYPE_ERROR: - return env; - default: - cant_happen("unrecognized type %d in annotateCexp", x->type); + case CEXP_TYPE_APPLY: + return annotateCexpApply(x->val.apply, env); + case CEXP_TYPE_IFF: + return annotateCexpIf(x->val.iff, env); + case CEXP_TYPE_COND: + return annotateCexpCond(x->val.cond, env); + case CEXP_TYPE_CALLCC: + return annotateAexp(x->val.callCC, env); + case CEXP_TYPE_LETREC: + return annotateCexpLetRec(x->val.letRec, env); + case CEXP_TYPE_AMB: + return annotateCexpAmb(x->val.amb, env); + case CEXP_TYPE_CUT: + return annotateCexpCut(x->val.cut, env); + case CEXP_TYPE_MATCH: + return annotateCexpMatch(x->val.match, env); + case CEXP_TYPE_BACK: + case CEXP_TYPE_ERROR: + return env; + default: + cant_happen("unrecognized type %d in annotateCexp", x->type); } } static AnfEnv *annotateExpEnv(AnfEnv *env) { int nBindings = 0; AnfEnv *orig = env; + orig->isCapturing = true; while (env != NULL) { - nBindings += countAnfIntTable(env->table); + nBindings += countIntMap(env->table); if (env->isNameSpace) { env->nBindings = nBindings; return orig; @@ -463,7 +471,8 @@ static AnfEnv *annotateExpEnv(AnfEnv *env) { cant_happen("failed to find nameSpace env"); } -static AexpAnnotatedVar *lookUpNameSpaceInEnv(ParserInfo I, Index index, AnfEnv *env) { +static AexpAnnotatedVar *lookUpNameSpaceInEnv(ParserInfo I, Index index, + AnfEnv *env) { HashSymbol *name = makeNsName(index); return annotateAexpVar(I, name, env); } @@ -475,11 +484,12 @@ static AnfEnv *annotateAnfExpLookUp(AnfExpLookUp *lookUp, AnfEnv *env) { cant_happen("nameSpace index %u out of range", lookUp->nameSpace); } #endif - lookUp->annotatedVar = lookUpNameSpaceInEnv(CPI(lookUp), lookUp->nameSpace, env); + lookUp->annotatedVar = + lookUpNameSpaceInEnv(CPI(lookUp), lookUp->nameSpace, env); return annotateExp(lookUp->body, envs->entries[lookUp->nameSpace]); } -static AnfEnv * annotateExp(AnfExp *x, AnfEnv *env) { +static AnfEnv *annotateExp(AnfExp *x, AnfEnv *env) { if (x == NULL) { return env; } @@ -491,20 +501,20 @@ static AnfEnv * annotateExp(AnfExp *x, AnfEnv *env) { eprintf("\n"); #endif switch (x->type) { - case ANFEXP_TYPE_AEXP: - return annotateAexp(x->val.aexp, env); - case ANFEXP_TYPE_CEXP: - return annotateCexp(x->val.cexp, env); - case ANFEXP_TYPE_LET: - return annotateAnfExpLet(x->val.let, env); - case ANFEXP_TYPE_ENV: - return annotateExpEnv(env); - case ANFEXP_TYPE_DONE: - return env; - case ANFEXP_TYPE_LOOKUP: - return annotateAnfExpLookUp(x->val.lookUp, env); - default: - cant_happen("unrecognized type %s", anfExpTypeName(x->type)); + case ANFEXP_TYPE_AEXP: + return annotateAexp(x->val.aexp, env); + case ANFEXP_TYPE_CEXP: + return annotateCexp(x->val.cexp, env); + case ANFEXP_TYPE_LET: + return annotateAnfExpLet(x->val.let, env); + case ANFEXP_TYPE_ENV: + return annotateExpEnv(env); + case ANFEXP_TYPE_DONE: + return env; + case ANFEXP_TYPE_LOOKUP: + return annotateAnfExpLookUp(x->val.lookUp, env); + default: + cant_happen("unrecognized type %s", anfExpTypeName(x->type)); } } @@ -535,7 +545,7 @@ static int calculateAdjustment(AnfEnv *env) { while (env != NULL) { if (env->isLocal) { if (env->next) { - adjustment += countAnfIntTable(env->next->table); + adjustment += countIntMap(env->next->table); } env = env->next; } else { @@ -554,7 +564,7 @@ static bool locate(HashSymbol *var, AnfEnv *env, int *frame, int *offset) { #endif *frame = 0; while (env != NULL) { - if (getAnfIntTable(env->table, var, offset)) { + if (getIntMap(env->table, var, offset)) { #ifdef DEBUG_ANNOTATE eprintf(" -> [%d:%d]\n", *frame, *offset); #endif diff --git a/src/ast.yaml b/src/ast.yaml index 1531f35a..5235bda0 100644 --- a/src/ast.yaml +++ b/src/ast.yaml @@ -1,3 +1,4 @@ + # # CEKF - VM supporting amb # Copyright (C) 2022-2024 Bill Hails @@ -24,9 +25,10 @@ config: complicated. The complexity is reduced downstream by conversion to simple lambda form. parserInfo: true + includes: + - utils.h limited_includes: - bigint.h - - file_id.h structs: @@ -146,13 +148,11 @@ structs: data: symbol: HashSymbol originalImpl: AstExpression + isLazy: bool=false - AstDefMacro: + AstDefLazy: meta: - brief: AST Macro Definition - description: >- - A macro definition in the AST, used to define - lazy functions. + brief: AST Lazy Function Definition data: name: HashSymbol definition: AstAltFunction @@ -493,12 +493,12 @@ unions: brief: AST Definition description: >- A definition in the AST, which can be a function, - type definition, alias, or macro. + type definition, alias, or lazy function. data: define: AstDefine multi: AstMultiDefine typeDef: AstTypeDef - macro: AstDefMacro + lazy: AstDefLazy alias: AstAlias blank: void_ptr builtinsSlot: void_ptr # Placeholder for builtins slot @@ -560,15 +560,6 @@ unions: assertion: AstExpression error: AstExpression -hashes: - AstIntTable: - meta: - brief: AST Integer Table - description: >- - A hash table mapping symbols to integers. - data: - entries: int - arrays: AstNameSpaceArray: meta: @@ -588,14 +579,6 @@ arrays: data: entries: file_id - AstStringArray: - meta: - brief: AST String Array - description: >- - A simple array of strings. - data: - entries: string - AstExpressionArray: meta: brief: AST Expression Array @@ -604,10 +587,4 @@ arrays: data: entries: AstExpression - AstUTF8: - meta: - brief: A UTF-8 encoded string. - data: - entries: uchar - primitives: !include primitives.yaml diff --git a/src/ast_helper.c b/src/ast_helper.c index 09cb41f9..17fe0529 100644 --- a/src/ast_helper.c +++ b/src/ast_helper.c @@ -16,9 +16,9 @@ * along with this program. If not, see . */ -#include #include "ast_helper.h" #include "symbol.h" +#include AstNameSpaceArray *nameSpaces = NULL; @@ -31,9 +31,7 @@ void printAstSymbol(struct HashSymbol *x, int depth) { eprintf("AstSymbol[\"%s\"]", x->name); } -void markNameSpaces() { - markAstNameSpaceArray(nameSpaces); -} +void markNameSpaces() { markAstNameSpaceArray(nameSpaces); } void initNameSpaces() { if (nameSpaces == NULL) { @@ -42,19 +40,17 @@ void initNameSpaces() { } // for tests -void forceInitNameSpaces() { - nameSpaces = newAstNameSpaceArray(); -} +void forceInitNameSpaces() { nameSpaces = newAstNameSpaceArray(); } -int lookUpNameSpace(AgnosticFileId *id) { +int lookUpNameSpace(FileId *id) { #ifdef SAFETY_CHECKS if (nameSpaces == NULL) { cant_happen("null nameSpace"); } #endif for (Index i = 0; i < nameSpaces->size; i++) { - if (cmpAgnosticFileId(id, nameSpaces->entries[i]->id) == CMP_EQ) { - return (int) i; + if (eqFileId(id, nameSpaces->entries[i]->id)) { + return (int)i; } } return -1; @@ -66,5 +62,6 @@ AstProg *astNestToProg(AstNest *nest) { cant_happen("null nameSpace"); } #endif - return newAstProg(CPI(nest), nest->definitions, nameSpaces, nest->expressions); + return newAstProg(CPI(nest), nest->definitions, nameSpaces, + nest->expressions); } diff --git a/src/ast_helper.h b/src/ast_helper.h index f2d2c01f..26463f1a 100644 --- a/src/ast_helper.h +++ b/src/ast_helper.h @@ -1,5 +1,5 @@ #ifndef cekf_ast_helper_h -# define cekf_ast_helper_h +#define cekf_ast_helper_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,11 +18,15 @@ * along with this program. If not, see . */ -# include "ast.h" -# include "hash.h" -# include "memory.h" +#include "ast.h" +#include "hash.h" +#include "memory.h" -extern AstNameSpaceArray *nameSpaces; +struct FileId; + +struct AstNameSpaceArray; + +extern struct AstNameSpaceArray *nameSpaces; void markAstSymbolTable(void); @@ -32,9 +36,12 @@ void initNameSpaces(); void forceInitNameSpaces(); -int lookUpNameSpace(AgnosticFileId *); +int lookUpNameSpace(struct FileId *); + +struct AstProg; +struct AstNest; -AstProg *astNestToProg(AstNest *nest); +struct AstProg *astNestToProg(struct AstNest *nest); void markNameSpaces(); diff --git a/src/ast_pp.c b/src/ast_pp.c index 5a40dd6e..1b8859af 100644 --- a/src/ast_pp.c +++ b/src/ast_pp.c @@ -1,74 +1,78 @@ /* * 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 . */ -#include #include +#include +#include +#include +#include +#include +#include "ast.h" +#include "ast_pp.h" +#include "bigint.h" #include "pratt.h" -#include "pratt_parser.h" #include "pratt_debug.h" #include "pratt_functions.h" +#include "pratt_parser.h" #include "pratt_scanner.h" -#include "symbols.h" -#include "ast.h" -#include "bigint.h" #include "print_generator.h" -#include "file_id.h" -#include "ast_pp.h" - -static void ppAstDefMacro(AstUTF8 *, AstDefMacro *); -static void ppAstDefMulti(AstUTF8 *, AstMultiDefine *); -static void ppAstDefinitions(AstUTF8 *, AstDefinitions *); -static void ppAstDefinition(AstUTF8 *, AstDefinition *); -static void ppAstDefine(AstUTF8 *, AstDefine *); -static void ppAstTypeDef(AstUTF8 *, AstTypeDef *); -static void ppAstAlias(AstUTF8 *, AstAlias *); -static void ppAstTypeSig(AstUTF8 *, AstTypeSig *); -static void ppAstType(AstUTF8 *, AstType *); -static void ppAstTypeBody(AstUTF8 *, AstTypeBody *); -static void ppAstTypeConstructor(AstUTF8 *, AstTypeConstructor *); -static void ppAstTypeConstructorArgs(AstUTF8 *, AstTypeConstructorArgs *); -static void ppAstTypeList(AstUTF8 *, AstTypeList *); -static void ppAstTypeMap(AstUTF8 *, AstTypeMap *); -static void ppAstExpressions(AstUTF8 *, AstExpressions *); -static void ppAstTypeSymbols(AstUTF8 *, AstTypeSymbols *); -static void ppAstTypeClause(AstUTF8 *, AstTypeClause *); -static void ppAstTypeFunction(AstUTF8 *, AstTypeFunction *); -static void ppAstLookUpOrSymbol(AstUTF8 *, AstLookUpOrSymbol *); -static void ppAstLookUpSymbol(AstUTF8 *, AstLookUpSymbol *); -static void ppAstCompositeFunction(AstUTF8 *, AstCompositeFunction *); -static void ppAstFunction(AstUTF8 *, AstFunction *); -static void ppAstFargList(AstUTF8 *, AstFargList *); -static void ppAstTaggedArgList(AstUTF8 *, AstTaggedArgList *); -static void ppastFarg(AstUTF8 *, AstFarg *); -static void ppAstNamedArg(AstUTF8 *, AstNamedArg *); -static void ppAstUnpack(AstUTF8 *, AstUnpack *); -static void ppAstUnpackStruct(AstUTF8 *, AstUnpackStruct *); -static void ppAstIff(AstUTF8 *, AstIff *); -static void ppAstLookUp(AstUTF8 *, AstLookUp *); -static void ppAstPrint(AstUTF8 *, AstPrint *); -static void ppAstStruct(AstUTF8 *, AstStruct *); -static void ppAstTaggedExpressions(AstUTF8 *, AstTaggedExpressions *); - -static void ppMaybeBigInt(AstUTF8 *, MaybeBigInt *); -static void ppUnicodeChar(AstUTF8 *, Character); -static void ppHashSymbol(AstUTF8 *, HashSymbol *); - -void ppAstNest(AstUTF8 *dest, AstNest *nest) { +#include "symbols.h" +#include "utils.h" + +static void ppAstDefLazy(SCharArray *, AstDefLazy *); +static void ppAstDefMulti(SCharArray *, AstMultiDefine *); +static void ppAstDefinitions(SCharArray *, AstDefinitions *); +static void ppAstDefinition(SCharArray *, AstDefinition *); +static void ppAstDefine(SCharArray *, AstDefine *); +static void ppAstTypeDef(SCharArray *, AstTypeDef *); +static void ppAstAlias(SCharArray *, AstAlias *); +static void ppAstTypeSig(SCharArray *, AstTypeSig *); +static void ppAstType(SCharArray *, AstType *); +static void ppAstTypeBody(SCharArray *, AstTypeBody *); +static void ppAstTypeConstructor(SCharArray *, AstTypeConstructor *); +static void ppAstTypeConstructorArgs(SCharArray *, AstTypeConstructorArgs *); +static void ppAstTypeList(SCharArray *, AstTypeList *); +static void ppAstTypeMap(SCharArray *, AstTypeMap *); +static void ppAstExpressions(SCharArray *, AstExpressions *); +static void ppAstTypeSymbols(SCharArray *, AstTypeSymbols *); +static void ppAstTypeClause(SCharArray *, AstTypeClause *); +static void ppAstTypeFunction(SCharArray *, AstTypeFunction *); +static void ppAstLookUpOrSymbol(SCharArray *, AstLookUpOrSymbol *); +static void ppAstLookUpSymbol(SCharArray *, AstLookUpSymbol *); +static void ppAstCompositeFunction(SCharArray *, AstCompositeFunction *); +static void ppAstFunction(SCharArray *, AstFunction *); +static void ppAstFargList(SCharArray *, AstFargList *); +static void ppAstTaggedArgList(SCharArray *, AstTaggedArgList *); +static void ppastFarg(SCharArray *, AstFarg *); +static void ppAstNamedArg(SCharArray *, AstNamedArg *); +static void ppAstUnpack(SCharArray *, AstUnpack *); +static void ppAstUnpackStruct(SCharArray *, AstUnpackStruct *); +static void ppAstIff(SCharArray *, AstIff *); +static void ppAstLookUp(SCharArray *, AstLookUp *); +static void ppAstPrint(SCharArray *, AstPrint *); +static void ppAstStruct(SCharArray *, AstStruct *); +static void ppAstTaggedExpressions(SCharArray *, AstTaggedExpressions *); + +static void ppMaybeBigInt(SCharArray *, MaybeBigInt *); +static void ppUnicodeChar(SCharArray *, Character); +static void ppHashSymbol(SCharArray *, HashSymbol *); + +void ppAstNest(SCharArray *dest, AstNest *nest) { psprintf(dest, "{ "); if (nest) { if (nest->definitions) { @@ -88,13 +92,14 @@ void ppAstNest(AstUTF8 *dest, AstNest *nest) { psprintf(dest, "}"); } -void ppAstNameSpaceImpl(AstUTF8 *dest, AstNameSpaceImpl *impl) { - psprintf(dest, "\"%s\": {", impl->id->name); +void ppAstNameSpaceImpl(SCharArray *dest, AstNameSpaceImpl *impl) { + psprintf(dest, "\"%u:%u:%lu\": {", major(impl->id->stDev), + minor(impl->id->stDev), impl->id->stIno); ppAstDefinitions(dest, impl->definitions); psprintf(dest, "}"); } -void ppAstProg(AstUTF8 *dest, AstProg *prog) { +void ppAstProg(SCharArray *dest, AstProg *prog) { psprintf(dest, "preamble: {"); ppAstDefinitions(dest, prog->preamble); psprintf(dest, "} nameSpaces: ["); @@ -106,7 +111,7 @@ void ppAstProg(AstUTF8 *dest, AstProg *prog) { psprintf(dest, "}"); } -void ppAstDefinitions(AstUTF8 *dest, AstDefinitions *definitions) { +void ppAstDefinitions(SCharArray *dest, AstDefinitions *definitions) { while (definitions) { ppAstDefinition(dest, definitions->definition); psprintf(dest, "; "); @@ -114,40 +119,40 @@ void ppAstDefinitions(AstUTF8 *dest, AstDefinitions *definitions) { } } -static void ppAstDefinition(AstUTF8 *dest, AstDefinition *definition) { +static void ppAstDefinition(SCharArray *dest, AstDefinition *definition) { switch (definition->type) { - case AST_DEFINITION_TYPE_DEFINE: - ppAstDefine(dest, definition->val.define); - break; - case AST_DEFINITION_TYPE_TYPEDEF: - ppAstTypeDef(dest, definition->val.typeDef); - break; - case AST_DEFINITION_TYPE_ALIAS: - ppAstAlias(dest, definition->val.alias); - break; - case AST_DEFINITION_TYPE_BLANK: - break; - case AST_DEFINITION_TYPE_MACRO: - ppAstDefMacro(dest, definition->val.macro); - break; - case AST_DEFINITION_TYPE_MULTI: - ppAstDefMulti(dest, definition->val.multi); - break; - default: - cant_happen("unrecognised %s", astDefinitionTypeName(definition->type)); + case AST_DEFINITION_TYPE_DEFINE: + ppAstDefine(dest, definition->val.define); + break; + case AST_DEFINITION_TYPE_TYPEDEF: + ppAstTypeDef(dest, definition->val.typeDef); + break; + case AST_DEFINITION_TYPE_ALIAS: + ppAstAlias(dest, definition->val.alias); + break; + case AST_DEFINITION_TYPE_BLANK: + break; + case AST_DEFINITION_TYPE_LAZY: + ppAstDefLazy(dest, definition->val.lazy); + break; + case AST_DEFINITION_TYPE_MULTI: + ppAstDefMulti(dest, definition->val.multi); + break; + default: + cant_happen("unrecognised %s", astDefinitionTypeName(definition->type)); } } -static void ppAstDefMacro(AstUTF8 *dest, AstDefMacro *defMacro) { - psprintf(dest, "macro "); - ppHashSymbol(dest, defMacro->name); +static void ppAstDefLazy(SCharArray *dest, AstDefLazy *defLazy) { + psprintf(dest, "lazy fn "); + ppHashSymbol(dest, defLazy->name); psprintf(dest, "("); - ppAstFargList(dest, defMacro->definition->altArgs->argList); + ppAstFargList(dest, defLazy->definition->altArgs->argList); psprintf(dest, ") "); - ppAstNest(dest, defMacro->definition->nest); + ppAstNest(dest, defLazy->definition->nest); } -static void ppAstSymbolList(AstUTF8 *dest, AstSymbolList *symbolList) { +static void ppAstSymbolList(SCharArray *dest, AstSymbolList *symbolList) { if (symbolList) { ppHashSymbol(dest, symbolList->symbol); if (symbolList->next) { @@ -157,7 +162,7 @@ static void ppAstSymbolList(AstUTF8 *dest, AstSymbolList *symbolList) { } } -static void ppAstDefMulti(AstUTF8 *dest, AstMultiDefine *define) { +static void ppAstDefMulti(SCharArray *dest, AstMultiDefine *define) { psprintf(dest, "#("); ppAstSymbolList(dest, define->symbols); psprintf(dest, ") = "); @@ -165,13 +170,13 @@ static void ppAstDefMulti(AstUTF8 *dest, AstMultiDefine *define) { psprintf(dest, "; "); } -static void ppAstDefine(AstUTF8 *dest, AstDefine *define) { +static void ppAstDefine(SCharArray *dest, AstDefine *define) { ppHashSymbol(dest, define->symbol); psprintf(dest, " = "); ppAstExpression(dest, define->expression); } -static void ppAstTypeDef(AstUTF8 *dest, AstTypeDef *typeDef) { +static void ppAstTypeDef(SCharArray *dest, AstTypeDef *typeDef) { psprintf(dest, "typedef "); ppAstTypeSig(dest, typeDef->typeSig); psprintf(dest, " {"); @@ -179,14 +184,14 @@ static void ppAstTypeDef(AstUTF8 *dest, AstTypeDef *typeDef) { psprintf(dest, "}"); } -static void ppAstAlias(AstUTF8 *dest, AstAlias *alias) { +static void ppAstAlias(SCharArray *dest, AstAlias *alias) { psprintf(dest, "alias "); ppHashSymbol(dest, alias->name); psprintf(dest, " = "); ppAstType(dest, alias->type); } -static void ppAstTypeSig(AstUTF8 *dest, AstTypeSig *typeSig) { +static void ppAstTypeSig(SCharArray *dest, AstTypeSig *typeSig) { ppHashSymbol(dest, typeSig->symbol); if (typeSig->typeSymbols != NULL) { psprintf(dest, "("); @@ -195,7 +200,7 @@ static void ppAstTypeSig(AstUTF8 *dest, AstTypeSig *typeSig) { } } -static void ppAstType(AstUTF8 *dest, AstType *type) { +static void ppAstType(SCharArray *dest, AstType *type) { if (type != NULL) { ppAstTypeClause(dest, type->typeClause); if (type->next) { @@ -205,7 +210,7 @@ static void ppAstType(AstUTF8 *dest, AstType *type) { } } -static void ppAstTypeBody(AstUTF8 *dest, AstTypeBody *typeBody) { +static void ppAstTypeBody(SCharArray *dest, AstTypeBody *typeBody) { if (typeBody != NULL) { ppAstTypeConstructor(dest, typeBody->typeConstructor); if (typeBody->next) { @@ -215,31 +220,35 @@ static void ppAstTypeBody(AstUTF8 *dest, AstTypeBody *typeBody) { } } -static void ppAstTypeConstructor(AstUTF8 *dest, AstTypeConstructor *typeConstructor) { +static void ppAstTypeConstructor(SCharArray *dest, + AstTypeConstructor *typeConstructor) { ppHashSymbol(dest, typeConstructor->symbol); ppAstTypeConstructorArgs(dest, typeConstructor->args); } -static void ppAstTypeConstructorArgs(AstUTF8 *dest, AstTypeConstructorArgs *typeConstructorArgs) { +static void +ppAstTypeConstructorArgs(SCharArray *dest, + AstTypeConstructorArgs *typeConstructorArgs) { if (typeConstructorArgs) { switch (typeConstructorArgs->type) { - case AST_TYPECONSTRUCTORARGS_TYPE_LIST: - psprintf(dest, "("); - ppAstTypeList(dest, typeConstructorArgs->val.list); - psprintf(dest, ")"); - break; - case AST_TYPECONSTRUCTORARGS_TYPE_MAP: - psprintf(dest, "{ "); - ppAstTypeMap(dest, typeConstructorArgs->val.map); - psprintf(dest, " }"); - break; - default: - cant_happen("unrecognised %s", astTypeConstructorArgsTypeName(typeConstructorArgs->type)); + case AST_TYPECONSTRUCTORARGS_TYPE_LIST: + psprintf(dest, "("); + ppAstTypeList(dest, typeConstructorArgs->val.list); + psprintf(dest, ")"); + break; + case AST_TYPECONSTRUCTORARGS_TYPE_MAP: + psprintf(dest, "{ "); + ppAstTypeMap(dest, typeConstructorArgs->val.map); + psprintf(dest, " }"); + break; + default: + cant_happen("unrecognised %s", astTypeConstructorArgsTypeName( + typeConstructorArgs->type)); } } } -static void ppAstTypeList(AstUTF8 *dest, AstTypeList *typeList) { +static void ppAstTypeList(SCharArray *dest, AstTypeList *typeList) { if (typeList) { ppAstType(dest, typeList->type); if (typeList->next) { @@ -249,7 +258,7 @@ static void ppAstTypeList(AstUTF8 *dest, AstTypeList *typeList) { } } -static void ppAstTypeMap(AstUTF8 *dest, AstTypeMap *typeMap) { +static void ppAstTypeMap(SCharArray *dest, AstTypeMap *typeMap) { if (typeMap) { ppHashSymbol(dest, typeMap->key); psprintf(dest, ": "); @@ -261,7 +270,7 @@ static void ppAstTypeMap(AstUTF8 *dest, AstTypeMap *typeMap) { } } -static void ppAstExpressions(AstUTF8 *dest, AstExpressions *expressions) { +static void ppAstExpressions(SCharArray *dest, AstExpressions *expressions) { if (expressions) { ppAstExpression(dest, expressions->expression); psprintf(dest, "; "); @@ -271,7 +280,7 @@ static void ppAstExpressions(AstUTF8 *dest, AstExpressions *expressions) { } } -static void ppAstTypeSymbols(AstUTF8 *dest, AstTypeSymbols *typeSymbols) { +static void ppAstTypeSymbols(SCharArray *dest, AstTypeSymbols *typeSymbols) { if (typeSymbols) { ppHashSymbol(dest, typeSymbols->typeSymbol); if (typeSymbols->next) { @@ -281,31 +290,31 @@ static void ppAstTypeSymbols(AstUTF8 *dest, AstTypeSymbols *typeSymbols) { } } -static void ppAstTypeClause(AstUTF8 *dest, AstTypeClause *typeClause) { +static void ppAstTypeClause(SCharArray *dest, AstTypeClause *typeClause) { switch (typeClause->type) { - case AST_TYPECLAUSE_TYPE_INTEGER: - psprintf(dest, "number"); - break; - case AST_TYPECLAUSE_TYPE_CHARACTER: - psprintf(dest, "char"); - break; - case AST_TYPECLAUSE_TYPE_VAR: - ppHashSymbol(dest, typeClause->val.var); - break; - case AST_TYPECLAUSE_TYPE_TYPEFUNCTION: - ppAstTypeFunction(dest, typeClause->val.typeFunction); - break; - case AST_TYPECLAUSE_TYPE_TYPETUPLE: - psprintf(dest, "("); - ppAstTypeList(dest, typeClause->val.typeTuple); - psprintf(dest, ")"); - break; - default: - cant_happen("unrecognised %s", astTypeClauseTypeName(typeClause->type)); + case AST_TYPECLAUSE_TYPE_INTEGER: + psprintf(dest, "number"); + break; + case AST_TYPECLAUSE_TYPE_CHARACTER: + psprintf(dest, "char"); + break; + case AST_TYPECLAUSE_TYPE_VAR: + ppHashSymbol(dest, typeClause->val.var); + break; + case AST_TYPECLAUSE_TYPE_TYPEFUNCTION: + ppAstTypeFunction(dest, typeClause->val.typeFunction); + break; + case AST_TYPECLAUSE_TYPE_TYPETUPLE: + psprintf(dest, "("); + ppAstTypeList(dest, typeClause->val.typeTuple); + psprintf(dest, ")"); + break; + default: + cant_happen("unrecognised %s", astTypeClauseTypeName(typeClause->type)); } } -static void ppAstTypeFunction(AstUTF8 *dest, AstTypeFunction *typeFunction) { +static void ppAstTypeFunction(SCharArray *dest, AstTypeFunction *typeFunction) { ppAstLookUpOrSymbol(dest, typeFunction->symbol); if (typeFunction->typeList) { psprintf(dest, "("); @@ -314,32 +323,35 @@ static void ppAstTypeFunction(AstUTF8 *dest, AstTypeFunction *typeFunction) { } } -static void ppAstLookUpOrSymbol(AstUTF8 *dest, AstLookUpOrSymbol *lookUpOrSymbol) { +static void ppAstLookUpOrSymbol(SCharArray *dest, + AstLookUpOrSymbol *lookUpOrSymbol) { switch (lookUpOrSymbol->type) { - case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: - ppAstLookUpSymbol(dest, lookUpOrSymbol->val.lookUp); - break; - case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: - ppHashSymbol(dest, lookUpOrSymbol->val.symbol); - break; - default: - cant_happen("unrecognised %s", astLookUpOrSymbolTypeName(lookUpOrSymbol->type)); + case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: + ppAstLookUpSymbol(dest, lookUpOrSymbol->val.lookUp); + break; + case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: + ppHashSymbol(dest, lookUpOrSymbol->val.symbol); + break; + default: + cant_happen("unrecognised %s", + astLookUpOrSymbolTypeName(lookUpOrSymbol->type)); } } -static void ppAstLookUpSymbol(AstUTF8 *dest, AstLookUpSymbol *lookUpSymbol) { +static void ppAstLookUpSymbol(SCharArray *dest, AstLookUpSymbol *lookUpSymbol) { ppHashSymbol(dest, lookUpSymbol->nsSymbol); psprintf(dest, "<%d>.", lookUpSymbol->nsId); ppHashSymbol(dest, lookUpSymbol->symbol); } -static void ppAstLookUp(AstUTF8 *dest, AstLookUp *lookUp) { +static void ppAstLookUp(SCharArray *dest, AstLookUp *lookUp) { ppHashSymbol(dest, lookUp->nsSymbol); psprintf(dest, "<%d>.", lookUp->nsId); ppAstExpression(dest, lookUp->expression); } -static void ppFunctionComponents(AstUTF8 *dest, AstCompositeFunction *compositeFunction) { +static void ppFunctionComponents(SCharArray *dest, + AstCompositeFunction *compositeFunction) { if (compositeFunction) { ppAstFunction(dest, compositeFunction->function); psprintf(dest, " "); @@ -347,8 +359,10 @@ static void ppFunctionComponents(AstUTF8 *dest, AstCompositeFunction *compositeF } } -static void ppAstCompositeFunction(AstUTF8 *dest, AstCompositeFunction *compositeFunction) { - if (compositeFunction == NULL) return; +static void ppAstCompositeFunction(SCharArray *dest, + AstCompositeFunction *compositeFunction) { + if (compositeFunction == NULL) + return; if (compositeFunction->unsafe) { psprintf(dest, "unsafe "); } @@ -357,15 +371,14 @@ static void ppAstCompositeFunction(AstUTF8 *dest, AstCompositeFunction *composit psprintf(dest, "}"); } -static void ppAstFunction(AstUTF8 *dest, AstFunction *function) { +static void ppAstFunction(SCharArray *dest, AstFunction *function) { psprintf(dest, "("); ppAstFargList(dest, function->argList); psprintf(dest, ") "); ppAstNest(dest, function->nest); - } -static void ppAstFargList(AstUTF8 *dest, AstFargList *argList) { +static void ppAstFargList(SCharArray *dest, AstFargList *argList) { if (argList) { ppastFarg(dest, argList->arg); if (argList->next) { @@ -375,63 +388,64 @@ static void ppAstFargList(AstUTF8 *dest, AstFargList *argList) { } } -static void ppastFarg(AstUTF8 *dest, AstFarg *arg) { +static void ppastFarg(SCharArray *dest, AstFarg *arg) { switch (arg->type) { - case AST_FARG_TYPE_WILDCARD: - psprintf(dest, "_"); - break; - case AST_FARG_TYPE_SYMBOL: - ppHashSymbol(dest, arg->val.symbol); - break; - case AST_FARG_TYPE_LOOKUP: - ppAstLookUpSymbol(dest, arg->val.lookUp); - break; - case AST_FARG_TYPE_NAMED: - ppAstNamedArg(dest, arg->val.named); - break; - case AST_FARG_TYPE_UNPACK: - ppAstUnpack(dest, arg->val.unpack); - break; - case AST_FARG_TYPE_UNPACKSTRUCT: - ppAstUnpackStruct(dest, arg->val.unpackStruct); - break; - case AST_FARG_TYPE_NUMBER: - ppMaybeBigInt(dest, arg->val.number); - break; - case AST_FARG_TYPE_CHARACTER: - ppUnicodeChar(dest, arg->val.character); - break; - case AST_FARG_TYPE_TUPLE: - psprintf(dest, "("); - ppAstFargList(dest, arg->val.tuple); - psprintf(dest, ")"); - break; - default: - break; + case AST_FARG_TYPE_WILDCARD: + psprintf(dest, "_"); + break; + case AST_FARG_TYPE_SYMBOL: + ppHashSymbol(dest, arg->val.symbol); + break; + case AST_FARG_TYPE_LOOKUP: + ppAstLookUpSymbol(dest, arg->val.lookUp); + break; + case AST_FARG_TYPE_NAMED: + ppAstNamedArg(dest, arg->val.named); + break; + case AST_FARG_TYPE_UNPACK: + ppAstUnpack(dest, arg->val.unpack); + break; + case AST_FARG_TYPE_UNPACKSTRUCT: + ppAstUnpackStruct(dest, arg->val.unpackStruct); + break; + case AST_FARG_TYPE_NUMBER: + ppMaybeBigInt(dest, arg->val.number); + break; + case AST_FARG_TYPE_CHARACTER: + ppUnicodeChar(dest, arg->val.character); + break; + case AST_FARG_TYPE_TUPLE: + psprintf(dest, "("); + ppAstFargList(dest, arg->val.tuple); + psprintf(dest, ")"); + break; + default: + break; } } -static void ppAstNamedArg(AstUTF8 *dest, AstNamedArg *namedArg) { +static void ppAstNamedArg(SCharArray *dest, AstNamedArg *namedArg) { ppHashSymbol(dest, namedArg->name); psprintf(dest, " = "); ppastFarg(dest, namedArg->arg); } -static void ppAstUnpack(AstUTF8 *dest, AstUnpack *unpack) { +static void ppAstUnpack(SCharArray *dest, AstUnpack *unpack) { ppAstLookUpOrSymbol(dest, unpack->symbol); psprintf(dest, "("); ppAstFargList(dest, unpack->argList); psprintf(dest, ")"); } -static void ppAstUnpackStruct(AstUTF8 *dest, AstUnpackStruct *unpackStruct) { +static void ppAstUnpackStruct(SCharArray *dest, AstUnpackStruct *unpackStruct) { ppAstLookUpOrSymbol(dest, unpackStruct->symbol); psprintf(dest, "{ "); ppAstTaggedArgList(dest, unpackStruct->argList); psprintf(dest, " }"); } -static void ppAstTaggedArgList(AstUTF8 *dest, AstTaggedArgList *taggedArgList) { +static void ppAstTaggedArgList(SCharArray *dest, + AstTaggedArgList *taggedArgList) { if (taggedArgList) { ppHashSymbol(dest, taggedArgList->tag); psprintf(dest, ": "); @@ -443,16 +457,16 @@ static void ppAstTaggedArgList(AstUTF8 *dest, AstTaggedArgList *taggedArgList) { } } -static void ppMaybeBigInt(AstUTF8 *dest, MaybeBigInt *maybe) { +static void ppMaybeBigInt(SCharArray *dest, MaybeBigInt *maybe) { size_t size = printSizeMaybeBigInt(maybe); - extendAstUTF8(dest, dest->size + size); - unsigned char *start = &dest->entries[dest->size]; - size = sprintMaybeBigInt((char *)start, maybe); + extendSCharArray(dest, dest->size + size); + char *start = &dest->entries[dest->size]; + size = sprintMaybeBigInt(start, maybe); dest->size += size; dest->size--; } -static void ppUnicodeChar(AstUTF8 *dest, Character c) { +static void ppUnicodeChar(SCharArray *dest, Character c) { char buf[MB_LEN_MAX]; int len = wctomb(buf, c); if (len > 0) { @@ -461,14 +475,15 @@ static void ppUnicodeChar(AstUTF8 *dest, Character c) { } } -static void ppHashSymbol(AstUTF8 *dest, HashSymbol *symbol) { +static void ppHashSymbol(SCharArray *dest, HashSymbol *symbol) { psprintf(dest, "%s", symbol->name); } -void ppAstFunCall(AstUTF8 *dest, AstFunCall *funCall) { +void ppAstFunCall(SCharArray *dest, AstFunCall *funCall) { ppAstExpression(dest, funCall->function); psprintf(dest, "("); - for (AstExpressions *expressions = funCall->arguments; expressions != NULL; expressions = expressions->next) { + for (AstExpressions *expressions = funCall->arguments; expressions != NULL; + expressions = expressions->next) { ppAstExpression(dest, expressions->expression); if (expressions->next) { psprintf(dest, ", "); @@ -477,7 +492,7 @@ void ppAstFunCall(AstUTF8 *dest, AstFunCall *funCall) { psprintf(dest, ")"); } -void ppAstCharacter(AstUTF8 *dest, Character c) { +void ppAstCharacter(SCharArray *dest, Character c) { char buffer[MB_LEN_MAX]; int len = wctomb(buffer, c); if (len > 0) { @@ -486,7 +501,7 @@ void ppAstCharacter(AstUTF8 *dest, Character c) { } } -void ppAstTuple(AstUTF8 *dest, AstExpressions *expressions) { +void ppAstTuple(SCharArray *dest, AstExpressions *expressions) { psprintf(dest, "("); while (expressions) { ppAstExpression(dest, expressions->expression); @@ -497,7 +512,7 @@ void ppAstTuple(AstUTF8 *dest, AstExpressions *expressions) { psprintf(dest, ")"); } -static void ppAstIff(AstUTF8 *dest, AstIff *iff) { +static void ppAstIff(SCharArray *dest, AstIff *iff) { psprintf(dest, "if ("); ppAstExpression(dest, iff->test); psprintf(dest, ") "); @@ -506,20 +521,21 @@ static void ppAstIff(AstUTF8 *dest, AstIff *iff) { ppAstNest(dest, iff->alternative); } -static void ppAstPrint(AstUTF8 *dest, AstPrint *print) { +static void ppAstPrint(SCharArray *dest, AstPrint *print) { psprintf(dest, "print("); ppAstExpression(dest, print->exp); psprintf(dest, ")"); } -static void ppAstStruct(AstUTF8 *dest, AstStruct *structure) { +static void ppAstStruct(SCharArray *dest, AstStruct *structure) { ppAstLookUpOrSymbol(dest, structure->symbol); psprintf(dest, "{ "); ppAstTaggedExpressions(dest, structure->expressions); psprintf(dest, " }"); } -static void ppAstTaggedExpressions(AstUTF8 *dest, AstTaggedExpressions *taggedExpressions) { +static void ppAstTaggedExpressions(SCharArray *dest, + AstTaggedExpressions *taggedExpressions) { if (taggedExpressions) { ppHashSymbol(dest, taggedExpressions->tag); psprintf(dest, ": ("); @@ -532,82 +548,82 @@ static void ppAstTaggedExpressions(AstUTF8 *dest, AstTaggedExpressions *taggedEx } } -void ppAstExpression(AstUTF8 *dest, AstExpression *expr) { +void ppAstExpression(SCharArray *dest, AstExpression *expr) { switch (expr->type) { - case AST_EXPRESSION_TYPE_NUMBER: - ppMaybeBigInt(dest, expr->val.number); - break; - case AST_EXPRESSION_TYPE_SYMBOL: - psprintf(dest, "%s", expr->val.symbol->name); - break; - case AST_EXPRESSION_TYPE_ANNOTATEDSYMBOL: - psprintf(dest, "%s", expr->val.annotatedSymbol->symbol->name); - psprintf(dest, "/*orig:"); - ppAstExpression(dest, expr->val.annotatedSymbol->originalImpl); - psprintf(dest, "*/"); - break; - case AST_EXPRESSION_TYPE_FUNCALL: - ppAstFunCall(dest, expr->val.funCall); - break; - case AST_EXPRESSION_TYPE_CHARACTER: - ppAstCharacter(dest, expr->val.character); - break; - case AST_EXPRESSION_TYPE_TUPLE: - ppAstTuple(dest, expr->val.tuple); - break; - case AST_EXPRESSION_TYPE_FUN: - ppAstCompositeFunction(dest, expr->val.fun); - break; - case AST_EXPRESSION_TYPE_IFF: - ppAstIff(dest, expr->val.iff); - break; - case AST_EXPRESSION_TYPE_NEST: - ppAstNest(dest, expr->val.nest); - break; - case AST_EXPRESSION_TYPE_BACK: - psprintf(dest, "back"); - break; - case AST_EXPRESSION_TYPE_ENV: - psprintf(dest, "env"); - break; - case AST_EXPRESSION_TYPE_LOOKUP: - ppAstLookUp(dest, expr->val.lookUp); - break; - case AST_EXPRESSION_TYPE_PRINT: - ppAstPrint(dest, expr->val.print); - break; - case AST_EXPRESSION_TYPE_STRUCTURE: - ppAstStruct(dest, expr->val.structure); - break; - case AST_EXPRESSION_TYPE_ASSERTION: - psprintf(dest, "assert("); - ppAstExpression(dest, expr->val.assertion); - psprintf(dest, ")"); - break; - case AST_EXPRESSION_TYPE_ERROR: - psprintf(dest, "error("); - ppAstExpression(dest, expr->val.error); - psprintf(dest, ")"); - break; - case AST_EXPRESSION_TYPE_TYPEOF: - psprintf(dest, "(typeof "); - ppAstExpression(dest, expr->val.typeOf->exp); - psprintf(dest, ")"); - break; - default: - cant_happen("unexpected %s", astExpressionTypeName(expr->type)); + case AST_EXPRESSION_TYPE_NUMBER: + ppMaybeBigInt(dest, expr->val.number); + break; + case AST_EXPRESSION_TYPE_SYMBOL: + psprintf(dest, "%s", expr->val.symbol->name); + break; + case AST_EXPRESSION_TYPE_ANNOTATEDSYMBOL: + psprintf(dest, "%s", expr->val.annotatedSymbol->symbol->name); + psprintf(dest, "/*orig:"); + ppAstExpression(dest, expr->val.annotatedSymbol->originalImpl); + psprintf(dest, "*/"); + break; + case AST_EXPRESSION_TYPE_FUNCALL: + ppAstFunCall(dest, expr->val.funCall); + break; + case AST_EXPRESSION_TYPE_CHARACTER: + ppAstCharacter(dest, expr->val.character); + break; + case AST_EXPRESSION_TYPE_TUPLE: + ppAstTuple(dest, expr->val.tuple); + break; + case AST_EXPRESSION_TYPE_FUN: + ppAstCompositeFunction(dest, expr->val.fun); + break; + case AST_EXPRESSION_TYPE_IFF: + ppAstIff(dest, expr->val.iff); + break; + case AST_EXPRESSION_TYPE_NEST: + ppAstNest(dest, expr->val.nest); + break; + case AST_EXPRESSION_TYPE_BACK: + psprintf(dest, "back"); + break; + case AST_EXPRESSION_TYPE_ENV: + psprintf(dest, "env"); + break; + case AST_EXPRESSION_TYPE_LOOKUP: + ppAstLookUp(dest, expr->val.lookUp); + break; + case AST_EXPRESSION_TYPE_PRINT: + ppAstPrint(dest, expr->val.print); + break; + case AST_EXPRESSION_TYPE_STRUCTURE: + ppAstStruct(dest, expr->val.structure); + break; + case AST_EXPRESSION_TYPE_ASSERTION: + psprintf(dest, "assert("); + ppAstExpression(dest, expr->val.assertion); + psprintf(dest, ")"); + break; + case AST_EXPRESSION_TYPE_ERROR: + psprintf(dest, "error("); + ppAstExpression(dest, expr->val.error); + psprintf(dest, ")"); + break; + case AST_EXPRESSION_TYPE_TYPEOF: + psprintf(dest, "(typeof "); + ppAstExpression(dest, expr->val.typeOf->exp); + psprintf(dest, ")"); + break; + default: + cant_happen("unexpected %s", astExpressionTypeName(expr->type)); } } -void psprintf(AstUTF8 *utf8, const char *message, ...) { +void psprintf(SCharArray *utf8, const char *message, ...) { va_list args; va_start(args, message); va_list copy; va_copy(copy, args); size_t size = vsnprintf(NULL, 0, message, args) + 1; - extendAstUTF8(utf8, utf8->size + size); - unsigned char *start = &utf8->entries[utf8->size]; - vsnprintf((char *)start, size, message, copy); + extendSCharArray(utf8, utf8->size + size); + char *start = &utf8->entries[utf8->size]; + vsnprintf(start, size, message, copy); va_end(args); va_end(copy); utf8->size += size; diff --git a/src/ast_pp.h b/src/ast_pp.h index c1ca1b55..e5312cea 100644 --- a/src/ast_pp.h +++ b/src/ast_pp.h @@ -1,27 +1,29 @@ #ifndef cekf_ast_pp_h -# define cekf_ast_pp_h +#define cekf_ast_pp_h /* * 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 . */ #include "ast.h" #include "pratt.h" +#include "utils.h" -void psprintf(AstUTF8 *, const char *, ...) __attribute__((format(printf, 2, 3))); -void ppAstExpression(AstUTF8 *, AstExpression *); +void psprintf(SCharArray *, const char *, ...) + __attribute__((format(printf, 2, 3))); +void ppAstExpression(SCharArray *, AstExpression *); #endif diff --git a/src/builtin_io.c b/src/builtin_io.c index cd65a655..abcf5da2 100644 --- a/src/builtin_io.c +++ b/src/builtin_io.c @@ -152,7 +152,7 @@ static Value builtin_fputc(Vec *args) { static Value builtin_fputs(Vec *args) { Opaque *data = args->entries[0].val.opaque; - CharVec *buf = listToUtf8(args->entries[1]); + SCharVec *buf = listToUtf8(args->entries[1]); int save = PROTECT(buf); fprintf((FILE *)data->data, "%s", buf->entries); UNPROTECT(save); @@ -160,7 +160,7 @@ static Value builtin_fputs(Vec *args) { } static Value builtin_puts(Vec *args) { - CharVec *buf = listToUtf8(args->entries[0]); + SCharVec *buf = listToUtf8(args->entries[0]); int save = PROTECT(buf); printf("%s", buf->entries); UNPROTECT(save); @@ -205,7 +205,7 @@ static void opaque_io_closedir(Opaque *data) { } static Value builtin_open(Vec *args) { - CharVec *fileName = listToUtf8(args->entries[0]); + SCharVec *fileName = listToUtf8(args->entries[0]); int save = PROTECT(fileName); int mode = args->entries[1].val.stdint; FILE *file = NULL; @@ -251,7 +251,7 @@ static Value builtin_open_memstream(Vec *args __attribute__((unused))) { } static Value builtin_opendir(Vec *args) { - CharVec *dirname = listToUtf8(args->entries[0]); + SCharVec *dirname = listToUtf8(args->entries[0]); int save = PROTECT(dirname); DIR *dir = opendir(dirname->entries); if (dir == NULL) { @@ -277,7 +277,7 @@ static Value builtin_opendir(Vec *args) { static Value builtin_ftype(Vec *args) { struct stat statbuf; - CharVec *dirname = listToUtf8(args->entries[0]); + SCharVec *dirname = listToUtf8(args->entries[0]); int save = PROTECT(dirname); int status = stat(dirname->entries, &statbuf); UNPROTECT(save); diff --git a/src/builtin_sqlite.c b/src/builtin_sqlite.c index 8d909036..d49235e8 100644 --- a/src/builtin_sqlite.c +++ b/src/builtin_sqlite.c @@ -69,7 +69,7 @@ static void opaque_sqlite3_finalize(Opaque *data) { } static Value builtin_sqlite3_open(Vec *v) { - CharVec *buf = listToUtf8(v->entries[0]); + SCharVec *buf = listToUtf8(v->entries[0]); int save = PROTECT(buf); sqlite3 *ppDb = NULL; int status = sqlite3_open(buf->entries, &ppDb); @@ -121,7 +121,7 @@ static Value builtin_sqlite3_prepare(Vec *vec) { } #endif Opaque *data = vec->entries[0].val.opaque; - CharVec *string = listToUtf8(vec->entries[1]); + SCharVec *string = listToUtf8(vec->entries[1]); int save = PROTECT(string); sqlite3_stmt *stmt = NULL; int res = sqlite3_prepare_v2(data->data, string->entries, -1, &stmt, NULL); @@ -176,7 +176,7 @@ static int helper_bind_number(sqlite3_stmt *stmt, int index, Value number) { } static int helper_bind_string(sqlite3_stmt *stmt, int index, Value string) { - CharVec *buf = listToUtf8(string); + SCharVec *buf = listToUtf8(string); return sqlite3_bind_text(stmt, index, buf->entries, strlen(buf->entries), helper_free_str); } diff --git a/src/builtins.yaml b/src/builtins.yaml index 7a0f83a8..ce3508d8 100644 --- a/src/builtins.yaml +++ b/src/builtins.yaml @@ -81,10 +81,5 @@ arrays: primitives: !include primitives.yaml external: - TcType: - data: - cname: "struct TcType *" - printFn: printTcType - markFn: markTcType - valued: true +- !include tc.yaml diff --git a/src/builtins_helper.c b/src/builtins_helper.c index 82e8fea0..978fd4ff 100644 --- a/src/builtins_helper.c +++ b/src/builtins_helper.c @@ -17,14 +17,14 @@ */ #include "builtins_helper.h" -#include -#include +#include "builtin_io.h" +#include "builtin_sqlite.h" #include "builtins_impl.h" #include "memory.h" #include "symbol.h" #include "tc_analyze.h" -#include "builtin_sqlite.h" -#include "builtin_io.h" +#include +#include static void registerRand(BuiltIns *registry); static void registerIncr(BuiltIns *registry); @@ -49,6 +49,7 @@ static void registerIsSymbol(BuiltIns *registry); static void registerIsUpper(BuiltIns *registry); static void registerIsValid(BuiltIns *registry); static void registerIsXdigit(BuiltIns *registry); +static void registerGetDec(BuiltIns *registry); static void registerChr(BuiltIns *registry); static void registerArgv(BuiltIns *registry, int argc, int cargc, char *argv[]); static void registerGetEnv(BuiltIns *registry); @@ -97,9 +98,7 @@ Value makeBasic(Value v, int code) { } } -static TcType *makeAnyType(void) { - return makeFreshVar("any"); -} +static TcType *makeAnyType(void) { return makeFreshVar("any"); } TcType *pushAnyArg(BuiltInArgs *args) { TcType *anyType = makeAnyType(); @@ -137,12 +136,13 @@ static char *makeInternalName(char *external) { // allocate buffer for "builtin$" + external + NUL size_t n = strlen(external); size_t len = n + 8 + 1; // 8 = strlen("builtin$") - char *buf = (char *) safeMalloc(len); + char *buf = (char *)safeMalloc(len); sprintf(buf, "builtin$%s", external); return buf; } -void pushNewBuiltIn(BuiltIns *registry, char *name, TcType *ret, BuiltInArgs *args, void *impl) { +void pushNewBuiltIn(BuiltIns *registry, char *name, TcType *ret, + BuiltInArgs *args, void *impl) { HashSymbol *external = newSymbol(name); char *internalC = makeInternalName(name); HashSymbol *internal = newSymbol(internalC); @@ -179,6 +179,7 @@ BuiltIns *registerBuiltIns(int argc, int cargc, char *argv[]) { registerIsUpper(res); registerIsValid(res); registerIsXdigit(res); + registerGetDec(res); registerChr(res); registerIO(res); registerSQLite(res); @@ -214,7 +215,8 @@ static void registerAssert(BuiltIns *registry) { int save = PROTECT(args); TcType *boolean = makeBoolean(); PROTECT(boolean); - pushNewBuiltIn(registry, "assertion", boolean, args, (void *)builtin_assert); + pushNewBuiltIn(registry, "assertion", boolean, args, + (void *)builtin_assert); UNPROTECT(save); } @@ -231,10 +233,12 @@ static void registerOrd(BuiltIns *registry) { static void registerUnicodeCategory(BuiltIns *registry) { BuiltInArgs *args = newBuiltInArgs(); int save = PROTECT(args); - TcType *resultType = makeTypeSig(newSymbol("unicode_general_category_type"), NULL, -1); + TcType *resultType = + makeTypeSig(newSymbol("unicode_general_category_type"), NULL, -1); PROTECT(resultType); pushCharacterArg(args); - pushNewBuiltIn(registry, "unicode_category", resultType, args, (void *)builtin_unicode_category); + pushNewBuiltIn(registry, "unicode_category", resultType, args, + (void *)builtin_unicode_category); UNPROTECT(save); } @@ -248,13 +252,15 @@ static void registerChr(BuiltIns *registry) { UNPROTECT(save); } -static void registerArgv(BuiltIns *registry, int argc, int cargc, char *argv[]) { +static void registerArgv(BuiltIns *registry, int argc, int cargc, + char *argv[]) { BuiltInArgs *args = newBuiltInArgs(); int save = PROTECT(args); pushIntegerArg(args); TcType *maybeStringType = makeMaybeStringType(); PROTECT(maybeStringType); - pushNewBuiltIn(registry, "argv", maybeStringType, args, (void *)builtin_args); + pushNewBuiltIn(registry, "argv", maybeStringType, args, + (void *)builtin_args); UNPROTECT(save); builtin_args_argc = argc; builtin_args_cargc = cargc; @@ -267,7 +273,8 @@ static void registerGetEnv(BuiltIns *registry) { pushStringArg(args); TcType *maybeStringType = makeMaybeStringType(); PROTECT(maybeStringType); - pushNewBuiltIn(registry, "getenv", maybeStringType, args, (void *)builtin_getenv); + pushNewBuiltIn(registry, "getenv", maybeStringType, args, + (void *)builtin_getenv); UNPROTECT(save); } @@ -275,7 +282,8 @@ static void registerRealPart(BuiltIns *registry) { BuiltInArgs *args = newBuiltInArgs(); int save = PROTECT(args); TcType *integerType = pushIntegerArg(args); - pushNewBuiltIn(registry, "com_real", integerType, args, (void *)builtin_real_part); + pushNewBuiltIn(registry, "com_real", integerType, args, + (void *)builtin_real_part); UNPROTECT(save); } @@ -283,7 +291,8 @@ static void registerImagPart(BuiltIns *registry) { BuiltInArgs *args = newBuiltInArgs(); int save = PROTECT(args); TcType *integerType = pushIntegerArg(args); - pushNewBuiltIn(registry, "com_imag", integerType, args, (void *)builtin_imag_part); + pushNewBuiltIn(registry, "com_imag", integerType, args, + (void *)builtin_imag_part); UNPROTECT(save); } @@ -291,7 +300,8 @@ static void registerMagPart(BuiltIns *registry) { BuiltInArgs *args = newBuiltInArgs(); int save = PROTECT(args); TcType *integerType = pushIntegerArg(args); - pushNewBuiltIn(registry, "com_mag", integerType, args, (void *)builtin_mag_part); + pushNewBuiltIn(registry, "com_mag", integerType, args, + (void *)builtin_mag_part); UNPROTECT(save); } @@ -299,7 +309,8 @@ static void registerThetaPart(BuiltIns *registry) { BuiltInArgs *args = newBuiltInArgs(); int save = PROTECT(args); TcType *integerType = pushIntegerArg(args); - pushNewBuiltIn(registry, "com_theta", integerType, args, (void *)builtin_theta_part); + pushNewBuiltIn(registry, "com_theta", integerType, args, + (void *)builtin_theta_part); UNPROTECT(save); } @@ -409,7 +420,8 @@ static void registerIsNumber(BuiltIns *registry) { TcType *boolean = makeBoolean(); PROTECT(boolean); pushCharacterArg(args); - pushNewBuiltIn(registry, "isnumber", boolean, args, (void *)builtin_isnumber); + pushNewBuiltIn(registry, "isnumber", boolean, args, + (void *)builtin_isnumber); UNPROTECT(save); } @@ -459,7 +471,8 @@ static void registerIsSymbol(BuiltIns *registry) { TcType *boolean = makeBoolean(); PROTECT(boolean); pushCharacterArg(args); - pushNewBuiltIn(registry, "issymbol", boolean, args, (void *)builtin_issymbol); + pushNewBuiltIn(registry, "issymbol", boolean, args, + (void *)builtin_issymbol); UNPROTECT(save); } @@ -489,6 +502,17 @@ static void registerIsXdigit(BuiltIns *registry) { TcType *boolean = makeBoolean(); PROTECT(boolean); pushCharacterArg(args); - pushNewBuiltIn(registry, "isxdigit", boolean, args, (void *)builtin_isxdigit); + pushNewBuiltIn(registry, "isxdigit", boolean, args, + (void *)builtin_isxdigit); UNPROTECT(save); } + +static void registerGetDec(BuiltIns *registry) { + BuiltInArgs *args = newBuiltInArgs(); + int save = PROTECT(args); + TcType *integer = newTcType_BigInteger(); + PROTECT(integer); + pushCharacterArg(args); + pushNewBuiltIn(registry, "getdec", integer, args, (void *)builtin_getdec); + UNPROTECT(save); +} \ No newline at end of file diff --git a/src/builtins_impl.c b/src/builtins_impl.c index 839a4a28..909566b6 100644 --- a/src/builtins_impl.c +++ b/src/builtins_impl.c @@ -154,6 +154,10 @@ Value builtin_unicode_category(Vec *args) { } } +Value builtin_getdec(Vec *args) { + return value_Stdint(unicode_getdec(args->entries[0].val.character)); +} + Value builtin_isalnum(Vec *args) { return unicode_isalnum(args->entries[0].val.character) ? vTrue : vFalse; } @@ -255,7 +259,7 @@ Value builtin_args(Vec *args) { } Value builtin_getenv(Vec *args) { - CharVec *name = listToUtf8(args->entries[0]); + SCharVec *name = listToUtf8(args->entries[0]); int save = PROTECT(name); char *value = getenv(name->entries); if (value == NULL) { diff --git a/src/builtins_impl.h b/src/builtins_impl.h index e595af19..a339049b 100644 --- a/src/builtins_impl.h +++ b/src/builtins_impl.h @@ -53,6 +53,7 @@ Value builtin_issymbol(Vec *args); Value builtin_isupper(Vec *args); Value builtin_isvalid(Vec *args); Value builtin_isxdigit(Vec *args); +Value builtin_getdec(Vec *args); void builtin_exit(Vec *args); extern int builtin_args_argc; diff --git a/src/bytecode.c b/src/bytecode.c index 246839b5..205612b2 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -19,21 +19,20 @@ // This file contains code for maintaining the bytecode array as well // as generating bytecode from ANF lambda expressions. -#include #include +#include #include #include "bytecode.h" -#include "debug.h" #include "common.h" +#include "debug.h" #ifdef DEBUG_BYTECODE -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif - void resetByteCodeArray(ByteCodeArray *b) { b->size = 0; for (size_t i = 0; i < b->capacity; i++) { @@ -69,22 +68,22 @@ static void writeLocation(ParserInfo I, ByteCodeArray *b, LocationArray *L) { char *charRep(Character c) { switch (c) { - case '\n': - return "\\n"; - case '\t': - return "\\t"; - case '\0': - return "\\0"; - default: { - static char buf[MB_LEN_MAX + 1]; - int len = wctomb(buf, c); - if (len > 0) { - buf[len] = '\0'; - } else { - buf[0] = '\0'; - } - return buf; + case '\n': + return "\\n"; + case '\t': + return "\\t"; + case '\0': + return "\\0"; + default: { + static char buf[MB_LEN_MAX + 1]; + int len = wctomb(buf, c); + if (len > 0) { + buf[len] = '\0'; + } else { + buf[0] = '\0'; } + return buf; + } } } @@ -153,8 +152,7 @@ static void addIrrational(ByteCodeArray *b, Double f) { b->size += sizeof(Double); } -__attribute__((unused)) -static int reserveInteger(ByteCodeArray *b) { +__attribute__((unused)) static int reserveInteger(ByteCodeArray *b) { int address = b->size; addInteger(b, 0); return address; @@ -179,7 +177,7 @@ static void addBig(ByteCodeArray *b, bigint bi) { //////////////////////////////////////////////////////////////////////////// -void writeAexpLam(AexpLam *x, ByteCodeArray *b , LocationArray *L) { +void writeAexpLam(AexpLam *x, ByteCodeArray *b, LocationArray *L) { ENTER(writeAexpLam); if (x == NULL) return; @@ -193,23 +191,24 @@ void writeAexpLam(AexpLam *x, ByteCodeArray *b , LocationArray *L) { LEAVE(writeAexpLam); } -void writeAexpAnnotatedVar(AexpAnnotatedVar *x, ByteCodeArray *b, LocationArray *L) { +void writeAexpAnnotatedVar(AexpAnnotatedVar *x, ByteCodeArray *b, + LocationArray *L) { ENTER(writeAexpAnnotatedVar); if (x == NULL) return; writeLocation(CPI(x), b, L); switch (x->type) { - case AEXPANNOTATEDVARTYPE_TYPE_ENV: - addByte(b, BYTECODES_TYPE_VAR); - addByte(b, x->frame); - addByte(b, x->offset); - break; - case AEXPANNOTATEDVARTYPE_TYPE_STACK: - addByte(b, BYTECODES_TYPE_LVAR); - addByte(b, x->offset); - break; - default: - cant_happen("unrecognised annotated var type"); + case AEXPANNOTATEDVARTYPE_TYPE_ENV: + addByte(b, BYTECODES_TYPE_VAR); + addByte(b, x->frame); + addByte(b, x->offset); + break; + case AEXPANNOTATEDVARTYPE_TYPE_STACK: + addByte(b, BYTECODES_TYPE_LVAR); + addByte(b, x->offset); + break; + default: + cant_happen("unrecognised annotated var type"); } LEAVE(writeAexpAnnotatedVar); @@ -224,50 +223,50 @@ void writeAexpPrimApp(AexpPrimApp *x, ByteCodeArray *b, LocationArray *L) { writeLocation(CPI(x), b, L); Byte prim; switch (x->type) { - case AEXPPRIMOP_TYPE_ADD: - prim = BYTECODES_TYPE_PRIM_ADD; - break; - case AEXPPRIMOP_TYPE_SUB: - prim = BYTECODES_TYPE_PRIM_SUB; - break; - case AEXPPRIMOP_TYPE_MUL: - prim = BYTECODES_TYPE_PRIM_MUL; - break; - case AEXPPRIMOP_TYPE_DIV: - prim = BYTECODES_TYPE_PRIM_DIV; - break; - case AEXPPRIMOP_TYPE_POW: - prim = BYTECODES_TYPE_PRIM_POW; - break; - case AEXPPRIMOP_TYPE_MOD: - prim = BYTECODES_TYPE_PRIM_MOD; - break; - case AEXPPRIMOP_TYPE_EQ: - prim = BYTECODES_TYPE_PRIM_EQ; - break; - case AEXPPRIMOP_TYPE_NE: - prim = BYTECODES_TYPE_PRIM_NE; - break; - case AEXPPRIMOP_TYPE_GT: - prim = BYTECODES_TYPE_PRIM_GT; - break; - case AEXPPRIMOP_TYPE_LT: - prim = BYTECODES_TYPE_PRIM_LT; - break; - case AEXPPRIMOP_TYPE_GE: - prim = BYTECODES_TYPE_PRIM_GE; - break; - case AEXPPRIMOP_TYPE_LE: - prim = BYTECODES_TYPE_PRIM_LE; - break; - case AEXPPRIMOP_TYPE_VEC: - prim = BYTECODES_TYPE_PRIM_VEC; - break; - case AEXPPRIMOP_TYPE_CMP: - prim = BYTECODES_TYPE_PRIM_CMP; - break; - default: - cant_happen("unrecognised AexpPrimOp in writeAexpPrimApp"); + case AEXPPRIMOP_TYPE_ADD: + prim = BYTECODES_TYPE_PRIM_ADD; + break; + case AEXPPRIMOP_TYPE_SUB: + prim = BYTECODES_TYPE_PRIM_SUB; + break; + case AEXPPRIMOP_TYPE_MUL: + prim = BYTECODES_TYPE_PRIM_MUL; + break; + case AEXPPRIMOP_TYPE_DIV: + prim = BYTECODES_TYPE_PRIM_DIV; + break; + case AEXPPRIMOP_TYPE_POW: + prim = BYTECODES_TYPE_PRIM_POW; + break; + case AEXPPRIMOP_TYPE_MOD: + prim = BYTECODES_TYPE_PRIM_MOD; + break; + case AEXPPRIMOP_TYPE_EQ: + prim = BYTECODES_TYPE_PRIM_EQ; + break; + case AEXPPRIMOP_TYPE_NE: + prim = BYTECODES_TYPE_PRIM_NE; + break; + case AEXPPRIMOP_TYPE_GT: + prim = BYTECODES_TYPE_PRIM_GT; + break; + case AEXPPRIMOP_TYPE_LT: + prim = BYTECODES_TYPE_PRIM_LT; + break; + case AEXPPRIMOP_TYPE_GE: + prim = BYTECODES_TYPE_PRIM_GE; + break; + case AEXPPRIMOP_TYPE_LE: + prim = BYTECODES_TYPE_PRIM_LE; + break; + case AEXPPRIMOP_TYPE_VEC: + prim = BYTECODES_TYPE_PRIM_VEC; + break; + case AEXPPRIMOP_TYPE_CMP: + prim = BYTECODES_TYPE_PRIM_CMP; + break; + default: + cant_happen("unrecognised AexpPrimOp in writeAexpPrimApp"); } addByte(b, prim); LEAVE(writeAexpPrimApp); @@ -291,7 +290,8 @@ void writeAexpMakeVec(AexpMakeVec *x, ByteCodeArray *b, LocationArray *L) { LEAVE(writeAexpMakeVec); } -void writeAexpNameSpaceArray(AexpNameSpaceArray *x, ByteCodeArray *b, LocationArray *L) { +void writeAexpNameSpaceArray(AexpNameSpaceArray *x, ByteCodeArray *b, + LocationArray *L) { if (x->size > 0) { writeLocation(CPI(x->entries[0]->body), b, L); addByte(b, BYTECODES_TYPE_NS_START); @@ -309,7 +309,8 @@ void writeAexpNameSpaceArray(AexpNameSpaceArray *x, ByteCodeArray *b, LocationAr } } -void writeAexpNameSpaces(AexpNameSpaces *x, ByteCodeArray *b, LocationArray *L) { +void writeAexpNameSpaces(AexpNameSpaces *x, ByteCodeArray *b, + LocationArray *L) { ENTER(writeAexpNameSpaces); writeAexpNameSpaceArray(x->nameSpaces, b, L); writeAnfExp(x->body, b, L); @@ -318,27 +319,32 @@ void writeAexpNameSpaces(AexpNameSpaces *x, ByteCodeArray *b, LocationArray *L) void writeCexpApply(CexpApply *x, ByteCodeArray *b, LocationArray *L) { ENTER(writeCexpApply); - // Preserve existing evaluation order: evaluate args left-to-right, then the function + // Preserve existing evaluation order: evaluate args left-to-right, then the + // function Index n = countAexpList(x->args); - // We'll conditionally emit args in a custom order; defer function emission below. + // We'll conditionally emit args in a custom order; defer function emission + // below. // Hybrid approach: if the callee is a direct lambda with known arity m // and there are extra arguments (n > m), emit an exact APPLY m followed // by (n - m) chained APPLY 1 instructions. This avoids VM over-application // while keeping the original evaluation order and stack discipline. - bool directLam = (x->function != NULL && x->function->type == AEXP_TYPE_LAM); + bool directLam = + (x->function != NULL && x->function->type == AEXP_TYPE_LAM); if (directLam) { int m = x->function->val.lam != NULL ? x->function->val.lam->nArgs : 0; + if ((int)n > m && m > 0) { // Collect args into an array to control emission order AexpList *cur = x->args; - Aexp **argv = NEW_ARRAY(Aexp*, n); + Aexp **argv = NEW_ARRAY(Aexp *, n); Index i = 0; while (cur != NULL && i < n) { argv[i++] = cur->exp; cur = cur->next; } - // Emit extra args (a_{m+1}..a_n) in reverse so that a_{m+1} is nearest to TOS after APPLY m + // Emit extra args (a_{m+1}..a_n) in reverse so that a_{m+1} is + // nearest to TOS after APPLY m for (Index k = n; k > (Index)m; k--) { writeAexp(argv[k - 1], b, L); } @@ -352,13 +358,14 @@ void writeCexpApply(CexpApply *x, ByteCodeArray *b, LocationArray *L) { writeLocation(CPI(x), b, L); addByte(b, BYTECODES_TYPE_APPLY); addByte(b, m); - // Chain the remaining (n - m) arguments one-by-one; they are already on the stack + // Chain the remaining (n - m) arguments one-by-one; they are + // already on the stack for (Index r = 0; r < (Index)((int)n - m); r++) { writeLocation(CPI(x), b, L); addByte(b, BYTECODES_TYPE_APPLY); addByte(b, 1); } - FREE_ARRAY(Aexp*, argv, n); + FREE_ARRAY(Aexp *, argv, n); LEAVE(writeCexpApply); return; } @@ -398,7 +405,7 @@ void writeCexpCharCondCases(int depth, Control *values, Control *addresses, return; } writeCexpCharCondCases(depth + 1, values, addresses, jumps, x->next, b, L); - if (x->next == NULL) { // default + if (x->next == NULL) { // default writeAnfExp(x->body, b, L); } else { writeCharacterAt(values[depth], b, x->option); @@ -414,12 +421,19 @@ void writeCexpCharCondCases(int depth, Control *values, Control *addresses, } // +-----------------------------------------------------------------------------------------------------+ -// | | -// | ..value.. | CHARCOND | numCases | value_1 | jump_1 | ... | value_n | jump_n | ..default.. | JMP | addr(end) | ..action_n.. | JMP | addr(end) | ... | ..action_1.. | ..end -// | | | | | -// +-------------------------|-----------+ +--------------------------------+ +// | | +// | ..value.. | CHARCOND | numCases | value_1 | jump_1 | ... | value_n | jump_n +// | ..default.. | JMP | addr(end) | ..action_n.. | JMP | addr(end) | ... | +// ..action_1.. | ..end +// | +// | +// | +// | | +// +-------------------------|-----------+ +// +--------------------------------+ // +-----------------------------------------------------------------+ -void writeCexpCharCond(CexpCharCondCases *x, ByteCodeArray *b, LocationArray *L) { +void writeCexpCharCond(CexpCharCondCases *x, ByteCodeArray *b, + LocationArray *L) { ENTER(writeCexpCharCond); writeLocation(CPI(x), b, L); addByte(b, BYTECODES_TYPE_CHARCOND); @@ -427,11 +441,15 @@ void writeCexpCharCond(CexpCharCondCases *x, ByteCodeArray *b, LocationArray *L) if (numCases <= 1) { cant_happen("zero cases in writeCexpCharCond"); } - numCases--; // don't count the default case + numCases--; // don't count the default case addWord(b, numCases); - Control *values = NEW_ARRAY(Control, numCases); // address in b for each index_i - Control *addresses = NEW_ARRAY(Control, numCases); // address in b for each addr(exp_i) - Control *jumps = NEW_ARRAY(Control, numCases); // address in b for the JMP patch address at the end of each expression + Control *values = + NEW_ARRAY(Control, numCases); // address in b for each index_i + Control *addresses = + NEW_ARRAY(Control, numCases); // address in b for each addr(exp_i) + Control *jumps = + NEW_ARRAY(Control, numCases); // address in b for the JMP patch address + // at the end of each expression for (Index i = 0; i < numCases; i++) { values[i] = reserveCharacter(b); addresses[i] = reserveWord(b); @@ -447,16 +465,19 @@ void writeCexpCharCond(CexpCharCondCases *x, ByteCodeArray *b, LocationArray *L) } void writeCexpIntCondCases(CexpIntCondCases *x, ByteCodeArray *b, - Control *endJumps, Control *dispatches, int index, LocationArray *L) { + Control *endJumps, Control *dispatches, int index, + LocationArray *L) { ENTER(writeCexpIntCondCases); if (x == NULL) return; writeCexpIntCondCases(x->next, b, endJumps, dispatches, index + 1, L); - if (x->next != NULL) { // last case is default, first one written, no dispatch as it follows the jmp table + if (x->next != NULL) { // last case is default, first one written, no + // dispatch as it follows the jmp table writeCurrentAddressAt(dispatches[index + 1], b); } writeAnfExp(x->body, b, L); - if (index != -1) { // -1 is first case. last one written out, doesn't need a JMP to end as the end immediately follows + if (index != -1) { // -1 is first case. last one written out, doesn't need a + // JMP to end as the end immediately follows writeLocation(CPI(x), b, L); addByte(b, BYTECODES_TYPE_JMP); endJumps[index] = reserveWord(b); @@ -474,37 +495,45 @@ void writeCexpIntCond(CexpIntCondCases *x, ByteCodeArray *b, LocationArray *L) { if (numCases <= 1) { cant_happen("zero cases in writeCexpIntCond"); } - numCases--; // don't count the default case + numCases--; // don't count the default case addWord(b, numCases); - // we start out by writing each of the cases, reserving a slot in memory for each dispatch address after each (variable length) value. - Control *dispatches = NEW_ARRAY(Control, numCases); // address of the slots for each dispatch address + // we start out by writing each of the cases, reserving a slot in memory for + // each dispatch address after each (variable length) value. + Control *dispatches = NEW_ARRAY( + Control, numCases); // address of the slots for each dispatch address { int i = 0; for (CexpIntCondCases *xx = x; xx != NULL; xx = xx->next) { if (xx->next == NULL) - break; // default case doesn't get a test + break; // default case doesn't get a test writeLocation(CPI(xx), b, L); switch (xx->option->type) { - case BI_SMALL: - addByte(b, xx->option->imag ? BYTECODES_TYPE_STDINT_IMAG : BYTECODES_TYPE_STDINT); - addInteger(b, xx->option->small); - break; - case BI_BIG: - addByte(b, xx->option->imag ? BYTECODES_TYPE_BIGINT_IMAG : BYTECODES_TYPE_BIGINT); - addBig(b, xx->option->big); - break; - case BI_IRRATIONAL: - addByte(b, xx->option->imag ? BYTECODES_TYPE_IRRATIONAL_IMAG : BYTECODES_TYPE_IRRATIONAL); - addIrrational(b, xx->option->irrational); - break; - default: - cant_happen("unsupported MaybeBigIntType %d", xx->option->type); + case BI_SMALL: + addByte(b, xx->option->imag ? BYTECODES_TYPE_STDINT_IMAG + : BYTECODES_TYPE_STDINT); + addInteger(b, xx->option->small); + break; + case BI_BIG: + addByte(b, xx->option->imag ? BYTECODES_TYPE_BIGINT_IMAG + : BYTECODES_TYPE_BIGINT); + addBig(b, xx->option->big); + break; + case BI_IRRATIONAL: + addByte(b, xx->option->imag ? BYTECODES_TYPE_IRRATIONAL_IMAG + : BYTECODES_TYPE_IRRATIONAL); + addIrrational(b, xx->option->irrational); + break; + default: + cant_happen("unsupported MaybeBigIntType %d", xx->option->type); } dispatches[i++] = reserveWord(b); } } - // next we right-recurse on the expressions (so the default directly follows the dispatch table) - Control *endJumps = NEW_ARRAY(Control, numCases); // address in b for the JMP patch address at the end of each expression which jumps to the end + // next we right-recurse on the expressions (so the default directly follows + // the dispatch table) + Control *endJumps = NEW_ARRAY( + Control, numCases); // address in b for the JMP patch address at the end + // of each expression which jumps to the end writeCexpIntCondCases(x, b, endJumps, dispatches, -1, L); // lastly we patch the escape addresses of the clauses. for (Index i = 0; i < numCases; i++) { @@ -519,15 +548,14 @@ void writeCexpCond(CexpCond *x, ByteCodeArray *b, LocationArray *L) { ENTER(writeCexpCond); writeAexp(x->condition, b, L); switch (x->cases->type) { - case CEXPCONDCASES_TYPE_INTCASES: - writeCexpIntCond(x->cases->val.intCases, b, L); - break; - case CEXPCONDCASES_TYPE_CHARCASES: - writeCexpCharCond(x->cases->val.charCases, b, L); - break; - default: - cant_happen("unrecognised type %d in writeCexpCond", - x->cases->type); + case CEXPCONDCASES_TYPE_INTCASES: + writeCexpIntCond(x->cases->val.intCases, b, L); + break; + case CEXPCONDCASES_TYPE_CHARCASES: + writeCexpCharCond(x->cases->val.charCases, b, L); + break; + default: + cant_happen("unrecognised type %d in writeCexpCond", x->cases->type); } LEAVE(writeCexpCond); } @@ -562,8 +590,8 @@ static int validateCexpMatch(CexpMatch *x) { for (int i = 0; i < 256; ++i) { if (seen[i]) { if (end) - cant_happen - ("non-contiguous match indices in validateCexpMatch"); + cant_happen( + "non-contiguous match indices in validateCexpMatch"); else count = i + 1; } else { @@ -604,7 +632,8 @@ void writeCexpMatch(CexpMatch *x, ByteCodeArray *b, LocationArray *L) { LEAVE(writeCexpMatch); } -void writeLetRecBindings(AnfLetRecBindings *x, ByteCodeArray *b, LocationArray *L) { +void writeLetRecBindings(AnfLetRecBindings *x, ByteCodeArray *b, + LocationArray *L) { ENTER(writeLetRecBindings); while (x != NULL) { writeAexp(x->val, b, L); @@ -656,18 +685,18 @@ void writeLookUp(AnfExpLookUp *x, ByteCodeArray *b, LocationArray *L) { } #endif writeLocation(CPI(x), b, L); - switch(x->annotatedVar->type) { - case AEXPANNOTATEDVARTYPE_TYPE_STACK: - addByte(b, BYTECODES_TYPE_NS_PUSHSTACK); - addWord(b, x->annotatedVar->offset); - break; - case AEXPANNOTATEDVARTYPE_TYPE_ENV: - addByte(b, BYTECODES_TYPE_NS_PUSHENV); - addWord(b, x->annotatedVar->frame); - addWord(b, x->annotatedVar->offset); - break; - default: - cant_happen("unrecognised annotation type %d", x->annotatedVar->type); + switch (x->annotatedVar->type) { + case AEXPANNOTATEDVARTYPE_TYPE_STACK: + addByte(b, BYTECODES_TYPE_NS_PUSHSTACK); + addWord(b, x->annotatedVar->offset); + break; + case AEXPANNOTATEDVARTYPE_TYPE_ENV: + addByte(b, BYTECODES_TYPE_NS_PUSHENV); + addWord(b, x->annotatedVar->frame); + addWord(b, x->annotatedVar->offset); + break; + default: + cant_happen("unrecognised annotation type %d", x->annotatedVar->type); } writeAnfExp(x->body, b, L); writeLocation(CPI(x->body), b, L); @@ -679,61 +708,56 @@ void writeAexp(Aexp *x, ByteCodeArray *b, LocationArray *L) { writeLocation(CPI(x), b, L); switch (x->type) { - case AEXP_TYPE_LAM:{ - writeAexpLam(x->val.lam, b, L); - } - break; - case AEXP_TYPE_VAR:{ - cant_happen("un-annotated var in writeAexp"); - } - break; - case AEXP_TYPE_ANNOTATEDVAR:{ - writeAexpAnnotatedVar(x->val.annotatedVar, b, L); - } - break; - case AEXP_TYPE_LITTLEINTEGER:{ - addByte(b, BYTECODES_TYPE_STDINT); - addInteger(b, x->val.littleInteger); - } - break; - case AEXP_TYPE_BIGINTEGER:{ - switch (x->val.bigInteger->type) { - case BI_SMALL: - addByte(b, x->val.bigInteger->imag ? BYTECODES_TYPE_STDINT_IMAG : BYTECODES_TYPE_STDINT); - addInteger(b, x->val.bigInteger->small); - break; - case BI_BIG: - addByte(b, x->val.bigInteger->imag ? BYTECODES_TYPE_BIGINT_IMAG : BYTECODES_TYPE_BIGINT); - addBig(b, x->val.bigInteger->big); - break; - case BI_IRRATIONAL: - addByte(b, x->val.bigInteger->imag ? BYTECODES_TYPE_IRRATIONAL_IMAG : BYTECODES_TYPE_IRRATIONAL); - addIrrational(b, x->val.bigInteger->irrational); - break; - default: - cant_happen("unsupported MaybeBigInt type %d", x->val.bigInteger->type); - } - } - break; - case AEXP_TYPE_CHARACTER:{ - addByte(b, BYTECODES_TYPE_CHAR); - addCharacter(b, x->val.character); - } - break; - case AEXP_TYPE_PRIM:{ - writeAexpPrimApp(x->val.prim, b, L); - } - break; - case AEXP_TYPE_MAKEVEC:{ - writeAexpMakeVec(x->val.makeVec, b, L); - } - break; - case AEXP_TYPE_NAMESPACES:{ - writeAexpNameSpaces(x->val.nameSpaces, b, L); - } + case AEXP_TYPE_LAM: { + writeAexpLam(x->val.lam, b, L); + } break; + case AEXP_TYPE_VAR: { + cant_happen("un-annotated var in writeAexp"); + } break; + case AEXP_TYPE_ANNOTATEDVAR: { + writeAexpAnnotatedVar(x->val.annotatedVar, b, L); + } break; + case AEXP_TYPE_LITTLEINTEGER: { + addByte(b, BYTECODES_TYPE_STDINT); + addInteger(b, x->val.littleInteger); + } break; + case AEXP_TYPE_BIGINTEGER: { + switch (x->val.bigInteger->type) { + case BI_SMALL: + addByte(b, x->val.bigInteger->imag ? BYTECODES_TYPE_STDINT_IMAG + : BYTECODES_TYPE_STDINT); + addInteger(b, x->val.bigInteger->small); + break; + case BI_BIG: + addByte(b, x->val.bigInteger->imag ? BYTECODES_TYPE_BIGINT_IMAG + : BYTECODES_TYPE_BIGINT); + addBig(b, x->val.bigInteger->big); + break; + case BI_IRRATIONAL: + addByte(b, x->val.bigInteger->imag ? BYTECODES_TYPE_IRRATIONAL_IMAG + : BYTECODES_TYPE_IRRATIONAL); + addIrrational(b, x->val.bigInteger->irrational); break; default: - cant_happen("unrecognized Aexp type %s", aexpTypeName(x->type)); + cant_happen("unsupported MaybeBigInt type %d", + x->val.bigInteger->type); + } + } break; + case AEXP_TYPE_CHARACTER: { + addByte(b, BYTECODES_TYPE_CHAR); + addCharacter(b, x->val.character); + } break; + case AEXP_TYPE_PRIM: { + writeAexpPrimApp(x->val.prim, b, L); + } break; + case AEXP_TYPE_MAKEVEC: { + writeAexpMakeVec(x->val.makeVec, b, L); + } break; + case AEXP_TYPE_NAMESPACES: { + writeAexpNameSpaces(x->val.nameSpaces, b, L); + } break; + default: + cant_happen("unrecognized Aexp type %s", aexpTypeName(x->type)); } LEAVE(writeAexp); } @@ -741,52 +765,42 @@ void writeAexp(Aexp *x, ByteCodeArray *b, LocationArray *L) { void writeCexp(Cexp *x, ByteCodeArray *b, LocationArray *L) { ENTER(writeCexp); switch (x->type) { - case CEXP_TYPE_APPLY:{ - writeCexpApply(x->val.apply, b, L); - } - break; - case CEXP_TYPE_IFF:{ - writeCexpIf(x->val.iff, b, L); - } - break; - case CEXP_TYPE_COND:{ - writeCexpCond(x->val.cond, b, L); - } - break; - case CEXP_TYPE_MATCH:{ - writeCexpMatch(x->val.match, b, L); - } - break; - case CEXP_TYPE_CALLCC:{ - writeAexp(x->val.callCC, b, L); - writeLocation(CPI(x), b, L); - addByte(b, BYTECODES_TYPE_CALLCC); - } - break; - case CEXP_TYPE_LETREC:{ - writeCexpLetRec(x->val.letRec, b, L); - } - break; - case CEXP_TYPE_AMB:{ - writeCexpAmb(x->val.amb, b, L); - } - break; - case CEXP_TYPE_CUT:{ - writeCexpCut(x->val.cut, b, L); - } - break; - case CEXP_TYPE_BACK:{ - writeLocation(CPI(x), b, L); - addByte(b, BYTECODES_TYPE_BACK); - } - break; - case CEXP_TYPE_ERROR:{ - writeLocation(CPI(x), b, L); - addByte(b, BYTECODES_TYPE_ERROR); - } - break; - default: - cant_happen("unrecognized Cexp type %s", cexpTypeName(x->type)); + case CEXP_TYPE_APPLY: { + writeCexpApply(x->val.apply, b, L); + } break; + case CEXP_TYPE_IFF: { + writeCexpIf(x->val.iff, b, L); + } break; + case CEXP_TYPE_COND: { + writeCexpCond(x->val.cond, b, L); + } break; + case CEXP_TYPE_MATCH: { + writeCexpMatch(x->val.match, b, L); + } break; + case CEXP_TYPE_CALLCC: { + writeAexp(x->val.callCC, b, L); + writeLocation(CPI(x), b, L); + addByte(b, BYTECODES_TYPE_CALLCC); + } break; + case CEXP_TYPE_LETREC: { + writeCexpLetRec(x->val.letRec, b, L); + } break; + case CEXP_TYPE_AMB: { + writeCexpAmb(x->val.amb, b, L); + } break; + case CEXP_TYPE_CUT: { + writeCexpCut(x->val.cut, b, L); + } break; + case CEXP_TYPE_BACK: { + writeLocation(CPI(x), b, L); + addByte(b, BYTECODES_TYPE_BACK); + } break; + case CEXP_TYPE_ERROR: { + writeLocation(CPI(x), b, L); + addByte(b, BYTECODES_TYPE_ERROR); + } break; + default: + cant_happen("unrecognized Cexp type %s", cexpTypeName(x->type)); } LEAVE(writeCexp); } @@ -796,31 +810,26 @@ void writeAnfExp(AnfExp *x, ByteCodeArray *b, LocationArray *L) { return; ENTER(writeAnfExp); switch (x->type) { - case ANFEXP_TYPE_AEXP:{ - writeAexp(x->val.aexp, b, L); - } - break; - case ANFEXP_TYPE_CEXP:{ - writeCexp(x->val.cexp, b, L); - } - break; - case ANFEXP_TYPE_LET:{ - writeAnfExpLet(x->val.let, b, L); - } - break; - case ANFEXP_TYPE_DONE:{ - writeLocation(CPI(x), b, L); - addByte(b, BYTECODES_TYPE_DONE); - } - break; - case ANFEXP_TYPE_LOOKUP:{ - writeLookUp(x->val.lookUp, b, L); - } - break; - case ANFEXP_TYPE_ENV: - break; - default: - cant_happen("unrecognized Exp type %s", anfExpTypeName(x->type)); + case ANFEXP_TYPE_AEXP: { + writeAexp(x->val.aexp, b, L); + } break; + case ANFEXP_TYPE_CEXP: { + writeCexp(x->val.cexp, b, L); + } break; + case ANFEXP_TYPE_LET: { + writeAnfExpLet(x->val.let, b, L); + } break; + case ANFEXP_TYPE_DONE: { + writeLocation(CPI(x), b, L); + addByte(b, BYTECODES_TYPE_DONE); + } break; + case ANFEXP_TYPE_LOOKUP: { + writeLookUp(x->val.lookUp, b, L); + } break; + case ANFEXP_TYPE_ENV: + break; + default: + cant_happen("unrecognized Exp type %s", anfExpTypeName(x->type)); } LEAVE(writeAnfExp); } @@ -871,7 +880,7 @@ bool writeBinaryOutputFile(ByteCodeArray *b, char *fileName) { fputc((CEKF_BYTECODE_VERSION & 0xFF00) >> 8, fh); fputc((CEKF_BYTECODE_VERSION & 0xFF), fh); for (Index i = 0; i < b->size; i++) { - fputc((int) b->entries[i], fh); + fputc((int)b->entries[i], fh); } fclose(fh); return true; diff --git a/src/cekf.c b/src/cekf.c index 73e0d62a..a942827b 100644 --- a/src/cekf.c +++ b/src/cekf.c @@ -269,7 +269,7 @@ static Value charArrayToList(CharacterArray *c) { } // converts a list of char to a utf8 string. -CharVec *listToUtf8(Value v) { +SCharVec *listToUtf8(Value v) { #ifdef SAFETY_CHECKS if (v.type != VALUE_TYPE_VEC) { cant_happen("unexpected %s", valueTypeName(v.type)); @@ -278,7 +278,7 @@ CharVec *listToUtf8(Value v) { CharacterArray *unicode = listToCharArray(v); int save = PROTECT(unicode); size_t size = wcstombs(NULL, unicode->entries, 0); - CharVec *buf = newCharVec((int)(size + 1)); + SCharVec *buf = newSCharVec((int)(size + 1)); PROTECT(buf); wcstombs(buf->entries, unicode->entries, size + 1); UNPROTECT(save); diff --git a/src/cekf.h b/src/cekf.h index 28c2d598..f61e537e 100644 --- a/src/cekf.h +++ b/src/cekf.h @@ -31,6 +31,7 @@ #include "common.h" #include "memory.h" #include "types.h" +#include "utils.h" #include "value.h" Vec *snapshotNameSpace(Stack *s); @@ -65,7 +66,7 @@ void dumpStack(Stack *stack); void dumpFrame(Frame *frame); #endif -CharVec *listToUtf8(Value v); +SCharVec *listToUtf8(Value v); Value utf8ToList(const char *utf8); Value makeNull(void); Value makePair(Value car, Value cdr); diff --git a/src/cekfs.yaml b/src/cekfs.yaml index 83c2c176..75ac481f 100644 --- a/src/cekfs.yaml +++ b/src/cekfs.yaml @@ -176,12 +176,6 @@ vectors: data: entries: Value - CharVec: - meta: - brief: A vector of chars - data: - entries: schar - stacks: Stack: meta: @@ -248,9 +242,4 @@ enums: primitives: !include primitives.yaml external: - BuiltInImplementation: - data: - cname: "struct BuiltInImplementation *" - printFn: printBuiltInImplementation - markFn: markBuiltInImplementation - valued: true +- !include builtins.yaml diff --git a/src/common.h b/src/common.h index 33d3b7df..2a9a8ba9 100644 --- a/src/common.h +++ b/src/common.h @@ -1,5 +1,5 @@ #ifndef cekf_common_h -# define cekf_common_h +#define cekf_common_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,15 +18,18 @@ * along with this program. If not, see . */ -# include -# include -# include -# include -# include +#include +#include +#include +#include +#include -# define NS_GLOBAL -1 +#define NS_GLOBAL -1 -# ifndef PRODUCTION_BUILD +// Null ParserInfo for use when location info is not available +#define NULLPI ((ParserInfo){.lineNo = 0, .fileName = NULL}) + +#ifndef PRODUCTION_BUILD // # define DEBUG_ALLOC // # define DEBUG_ANF // # define DEBUG_ANF_NORMALIZE @@ -36,7 +39,7 @@ // # define DEBUG_BYTECODE // # define DEBUG_CEKFS // # define DEBUG_DESUGARING -# define DEBUG_DUMP_CORE +#define DEBUG_DUMP_CORE // # define DEBUG_HASHTABLE // # define DEBUG_LAMBDA_CONVERT // # define DEBUG_LAMBDA_SUBSTITUTE @@ -49,43 +52,49 @@ // # define DEBUG_SLOW_STEP // # define DEBUG_SQLITE // # define DEBUG_STACK -// # define DEBUG_STEP -# ifndef NO_DEBUG_STRESS_GC -# define DEBUG_STRESS_GC -# endif +// #define DEBUG_STEP +#ifndef NO_DEBUG_STRESS_GC +#define DEBUG_STRESS_GC +#endif // # define DEBUG_TC // # define DEBUG_TIN_INSTANTIATION // # define DEBUG_TIN_SUBSTITUTION // # define DEBUG_TIN_UNIFICATION // # define DEBUG_TPMC_COMPARE // # define DEBUG_TPMC_LOGIC -// # define DEBUG_TPMC_MATCH +// #define DEBUG_TPMC_MATCH // # define DEBUG_TPMC_TRANSLATE -# define SAFETY_CHECKS -# endif +#define SAFETY_CHECKS +#endif + +#ifndef __GNUC__ +#define __attribute__(x) +#endif -# ifndef __GNUC__ -# define __attribute__(x) -# endif +#define errout stdout -# define errout stdout +// Forward declaration to avoid circular dependency with parser_info.h +struct ParserInfo; +typedef struct ParserInfo ParserInfo; void _cant_happen(char *file, int line, const char *message, ...) __attribute__((noreturn, format(printf, 3, 4))); -void can_happen(const char *message, ...) - __attribute__((format(printf, 1, 2))); +void can_happen(ParserInfo I, const char *message, ...) + __attribute__((format(printf, 2, 3))); +void vcan_happen(ParserInfo I, const char *message, va_list args); void eprintf(const char *message, ...) __attribute__((format(printf, 1, 2))); bool hadErrors(void); void clearErrors(void); #define cant_happen(...) _cant_happen(__FILE__, __LINE__, __VA_ARGS__) -# define PAD_WIDTH 2 +#define PAD_WIDTH 2 -#define ASSERT(assertion) do {\ - if (!(assertion)) { \ - cant_happen("assertion failed " #assertion); \ - } \ -} while (0); +#define ASSERT(assertion) \ + do { \ + if (!(assertion)) { \ + cant_happen("assertion failed " #assertion); \ + } \ + } while (0); #endif diff --git a/src/errors.c b/src/errors.c index ae7d119a..78b7b9e5 100644 --- a/src/errors.c +++ b/src/errors.c @@ -18,21 +18,21 @@ * common error handling. */ - -#include #include #include -#include +#include #include +#include #include "common.h" +#include "parser_info.h" static bool errors = false; /** * Handle a "can't happen" error by printing message and exiting. * Used by the `cant_happen` macro from common.h. - * + * * @param file the source file name (supplied by the macro) * @param line the source line number (supplied by the macro) * @param message the error message format string @@ -54,22 +54,40 @@ void _cant_happen(char *file, int line, const char *message, ...) { /** * Handle a "can happen" error by printing message and setting error flag. - * + * This is the va_list version for forwarding varargs. + * + * @param I the parser info containing file name and line number (use NULLPI if + * not available) + * @param message the error message format string + * @param args the error message arguments as va_list + */ +void vcan_happen(ParserInfo I, const char *message, va_list args) { + vfprintf(errout, message, args); + if (I.lineNo != 0) { + eprintf(" at +%d %s", I.lineNo, I.fileName); + } + eprintf("\n"); + errors = true; +} + +/** + * Handle a "can happen" error by printing message and setting error flag. + * + * @param I the parser info containing file name and line number (use NULLPI if + * not available) * @param message the error message format string * @param ... the error message arguments */ -void can_happen(const char *message, ...) { +void can_happen(ParserInfo I, const char *message, ...) { va_list args; va_start(args, message); - vfprintf(errout, message, args); + vcan_happen(I, message, args); va_end(args); - eprintf("\n"); - errors = true; } /** * Print a message to the error output. - * + * * @param message the message format string * @param ... the message arguments */ @@ -82,16 +100,12 @@ void eprintf(const char *message, ...) { /** * Check if any errors have occurred. - * + * * @return true if errors have occurred, false otherwise */ -bool hadErrors() { - return errors; -} +bool hadErrors() { return errors; } /** * Clear the error flag. */ -void clearErrors() { - errors = false; -} +void clearErrors() { errors = false; } diff --git a/src/file_id.c b/src/file_id.c deleted file mode 100644 index b8fb2f9d..00000000 --- a/src/file_id.c +++ /dev/null @@ -1,114 +0,0 @@ -/* - * CEKF - VM supporting amb - * Copyright (C) 2022-2023 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 . - * - * An attempt at an operating-system agnostic file id, at least in the sense - * that it can be redefined for different operating systems without having - * to change usage throughout the code, though the implementation here is - * POSIX-specific. - */ - -#include - -#include "common.h" -#include "file_id.h" - -/** - * Print an agnostic file id for debugging. - * - * @param id the agnostic file id - * @param depth the depth for pretty-printing - */ -void printAgnosticFileId(AgnosticFileId *id, int depth) { - if (id == NULL) { - eprintf("%*sFileId()", depth * PAD_WIDTH, ""); - } else { - eprintf("%*sFileId(%u:%u, %lu, \"%s\")", - depth * PAD_WIDTH, "", major(id->st_dev), minor(id->st_dev), id->st_ino, id->name); - } -} - -/** - * Mark an agnostic file id for gc protection. - * - * @param id the agnostic file id - */ -void markAgnosticFileId(AgnosticFileId *id) { - if (id == NULL) return; - if (MARKED(id)) return; - MARK(id); -} - -/** - * Free an agnostic file id. - * - * @param id the agnostic file id - */ -void freeAgnosticFileId(AgnosticFileId *id) { - if (id == NULL) return; - // 'name' is owned by this object (allocated via malloc/strdup in callers), - // so free it here before freeing the object itself. - if (id->name) free(id->name); - FREE(id, AgnosticFileId); -} - -/** - * Compare two agnostic file ids. - * - * @param a the first agnostic file id - * @param b the second agnostic file id - * @return the comparison result - */ -Cmp cmpAgnosticFileId(AgnosticFileId *a, AgnosticFileId *b) { - if (major(a->st_dev) == major(b->st_dev)) { - if (minor(a->st_dev) == minor(b->st_dev)) { - if (a->st_ino == b->st_ino) { - return CMP_EQ; - } else if (a->st_ino > b->st_ino) { - return CMP_GT; - } else { - return CMP_LT; - } - } else if (minor(a->st_dev) > minor(b->st_dev)) { - return CMP_GT; - } else { - return CMP_LT; - } - } else if (major(a->st_dev) > major(b->st_dev)) { - return CMP_GT; - } else { - return CMP_LT; - } -} - -/** - * Create an agnostic file id from a fileName. - * - * @param fileName the fileName - * @return the agnostic file id, or NULL if the file does not exist - */ -AgnosticFileId *makeAgnosticFileId(char *fileName) { - struct stat stats; - if (stat(fileName, &stats) == 0) { - AgnosticFileId *res = NEW(AgnosticFileId, OBJTYPE_AGNOSTICFILEID); - res->st_dev = stats.st_dev; - res->st_ino = stats.st_ino; - res->name = fileName; - return res; - } else { - return NULL; - } -} diff --git a/src/file_id.h b/src/file_id.h deleted file mode 100644 index 47c307c3..00000000 --- a/src/file_id.h +++ /dev/null @@ -1,45 +0,0 @@ -#ifndef cekf_file_id_h -# define cekf_file_id_h -/* - * CEKF - VM supporting amb - * Copyright (C) 2022-2023 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 . - * - * An attempt at an operating-system agnostic file id, at least in the sense - * that it can be redefined for different operating systems without having - * to change usage throughout the code, though the implementation here is - * POSIX-specific. - */ - - -#include - -#include "memory.h" -#include "cmp.h" - -typedef struct AgnosticFileId { - Header header; - dev_t st_dev; - ino_t st_ino; - char *name; -} AgnosticFileId; - -void printAgnosticFileId(AgnosticFileId *, int); -void markAgnosticFileId(AgnosticFileId *); -void freeAgnosticFileId(AgnosticFileId *); -Cmp cmpAgnosticFileId(AgnosticFileId *, AgnosticFileId *); -AgnosticFileId *makeAgnosticFileId(char *); - -#endif diff --git a/src/inline.c b/src/inline.c index fa0e554a..e2912c14 100644 --- a/src/inline.c +++ b/src/inline.c @@ -35,7 +35,6 @@ static LamBindings *inlineBindings(LamBindings *x); static LamLet *inlineLet(LamLet *x); static LamLetStar *inlineLetStar(LamLetStar *x); static LamAmb *inlineAmb(LamAmb *x); -static LamPrint *inlinePrint(LamPrint *x); static LamLookUp *inlineLookUp(LamLookUp *x); static LamTupleIndex *inlineTupleIndex(LamTupleIndex *x); static LamMatch *inlineMatch(LamMatch *x); @@ -79,6 +78,9 @@ static LamLam *inlineLam(LamLam *x) { static LamPrimApp *inlinePrim(LamPrimApp *x) { x->exp1 = inlineExp(x->exp1); x->exp2 = inlineExp(x->exp2); + if (x->replacement != NULL) { + x->replacement = inlineExp(x->replacement); + } return x; } @@ -99,7 +101,7 @@ static LamArgs *inlineArgs(LamArgs *x) { } static LamExp *inlineConstant(LamTypeConstructorInfo *x) { - if (x-> arity != 0) { + if (x->arity != 0) { cant_happen("missing arguments to constructor %s", x->name->name); } if (x->needsVec) { @@ -111,12 +113,12 @@ static LamExp *inlineConstant(LamTypeConstructorInfo *x) { static LamTypeConstructorInfo *resolveTypeConstructor(LamExp *x) { switch (x->type) { - case LAMEXP_TYPE_CONSTRUCTOR: - return getLamExp_Constructor(x); - case LAMEXP_TYPE_LOOKUP: - return resolveTypeConstructor(getLamExp_LookUp(x)->exp); - default: - return NULL; + case LAMEXP_TYPE_CONSTRUCTOR: + return getLamExp_Constructor(x); + case LAMEXP_TYPE_LOOKUP: + return resolveTypeConstructor(getLamExp_LookUp(x)->exp); + default: + return NULL; } } @@ -129,9 +131,11 @@ static LamExp *inlineApply(LamApply *x) { int nArgs = countLamArgs(x->args); if (info->needsVec) { if (nArgs == info->arity) { - return makeLamExp_Construct(CPI(x), info->name, info->index, x->args); + return makeLamExp_Construct(CPI(x), info->name, info->index, + x->args); } else { - cant_happen("wrong number of arguments to constructor %s, got %d, expected %d", + cant_happen("wrong number of arguments to constructor %s, got " + "%d, expected %d", info->name->name, nArgs, info->arity); } } else { @@ -184,11 +188,6 @@ static LamAmb *inlineAmb(LamAmb *x) { return x; } -static LamPrint *inlinePrint(LamPrint *x) { - x->exp = inlineExp(x->exp); - return x; -} - static LamLookUp *inlineLookUp(LamLookUp *x) { x->exp = inlineExp(x->exp); return x; @@ -208,14 +207,16 @@ static LamCond *inlineCond(LamCond *x) { static LamCondCases *inlineCondCases(LamCondCases *x) { if (x != NULL) { switch (x->type) { - case LAMCONDCASES_TYPE_INTEGERS: - setLamCondCases_Integers(x, inlineIntCondCases(getLamCondCases_Integers(x))); - break; - case LAMCONDCASES_TYPE_CHARACTERS: - setLamCondCases_Characters(x, inlineCharCondCases(getLamCondCases_Characters(x))); - break; - default: - cant_happen("unrecognized %s", lamCondCasesTypeName(x->type)); + case LAMCONDCASES_TYPE_INTEGERS: + setLamCondCases_Integers( + x, inlineIntCondCases(getLamCondCases_Integers(x))); + break; + case LAMCONDCASES_TYPE_CHARACTERS: + setLamCondCases_Characters( + x, inlineCharCondCases(getLamCondCases_Characters(x))); + break; + default: + cant_happen("unrecognized %s", lamCondCasesTypeName(x->type)); } } return x; @@ -238,91 +239,92 @@ static LamIntCondCases *inlineIntCondCases(LamIntCondCases *x) { } static LamExp *inlineExp(LamExp *x) { - if (x == NULL) return NULL; + if (x == NULL) + return NULL; switch (x->type) { - case LAMEXP_TYPE_VAR: - case LAMEXP_TYPE_STDINT: - case LAMEXP_TYPE_BIGINTEGER: - case LAMEXP_TYPE_CONSTANT: - case LAMEXP_TYPE_ENV: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_CHARACTER: - break; - case LAMEXP_TYPE_TYPEDEFS: - setLamExp_TypeDefs(x, inlineTypeDefs(getLamExp_TypeDefs(x))); - break; - case LAMEXP_TYPE_NAMESPACES: - setLamExp_NameSpaces(x, inlineNameSpaces(getLamExp_NameSpaces(x))); - break; - case LAMEXP_TYPE_LAM: - setLamExp_Lam(x, inlineLam(getLamExp_Lam(x))); - break; - case LAMEXP_TYPE_PRIM: - setLamExp_Prim(x, inlinePrim(getLamExp_Prim(x))); - break; - case LAMEXP_TYPE_SEQUENCE: - setLamExp_Sequence(x, inlineSequence(getLamExp_Sequence(x))); - break; - case LAMEXP_TYPE_MAKETUPLE: - setLamExp_MakeTuple(x, inlineArgs(getLamExp_MakeTuple(x))); - break; - case LAMEXP_TYPE_APPLY: - x = inlineApply(getLamExp_Apply(x)); - break; - case LAMEXP_TYPE_IFF: - setLamExp_Iff(x, inlineIff(getLamExp_Iff(x))); - break; - case LAMEXP_TYPE_CALLCC: - setLamExp_CallCC(x, inlineExp(getLamExp_CallCC(x))); - break; - case LAMEXP_TYPE_LETREC: - setLamExp_LetRec(x, inlineLetRec(getLamExp_LetRec(x))); - break; - case LAMEXP_TYPE_LET: - setLamExp_Let(x, inlineLet(getLamExp_Let(x))); - break; - case LAMEXP_TYPE_LETSTAR: - setLamExp_LetStar(x, inlineLetStar(getLamExp_LetStar(x))); - break; - case LAMEXP_TYPE_AMB: - setLamExp_Amb(x, inlineAmb(getLamExp_Amb(x))); - break; - case LAMEXP_TYPE_PRINT: - setLamExp_Print(x, inlinePrint(getLamExp_Print(x))); - break; - case LAMEXP_TYPE_LOOKUP: - setLamExp_LookUp(x, inlineLookUp(getLamExp_LookUp(x))); - break; - case LAMEXP_TYPE_TUPLEINDEX: - setLamExp_TupleIndex(x, inlineTupleIndex(getLamExp_TupleIndex(x))); - break; - case LAMEXP_TYPE_MATCH: - setLamExp_Match(x, inlineMatch(getLamExp_Match(x))); - break; - case LAMEXP_TYPE_TAG: - setLamExp_Tag(x, inlineExp(getLamExp_Tag(x))); - break; - case LAMEXP_TYPE_DECONSTRUCT: - getLamExp_Deconstruct(x)->exp = inlineExp(getLamExp_Deconstruct(x)->exp); - break; - case LAMEXP_TYPE_CONSTRUCTOR: - x = inlineConstant(getLamExp_Constructor(x)); - break; - case LAMEXP_TYPE_CONSTRUCT: - getLamExp_Construct(x)->args = inlineArgs(getLamExp_Construct(x)->args); - break; - case LAMEXP_TYPE_COND: - setLamExp_Cond(x, inlineCond(getLamExp_Cond(x))); - break; - case LAMEXP_TYPE_MAKEVEC: - cant_happen("encountered %s", lamExpTypeName(x->type)); - default: - cant_happen("unrecognised type %s", lamExpTypeName(x->type)); + case LAMEXP_TYPE_VAR: + case LAMEXP_TYPE_STDINT: + case LAMEXP_TYPE_BIGINTEGER: + case LAMEXP_TYPE_CONSTANT: + case LAMEXP_TYPE_ENV: + case LAMEXP_TYPE_ERROR: + case LAMEXP_TYPE_BACK: + case LAMEXP_TYPE_CHARACTER: + break; + case LAMEXP_TYPE_TYPEDEFS: + setLamExp_TypeDefs(x, inlineTypeDefs(getLamExp_TypeDefs(x))); + break; + case LAMEXP_TYPE_NAMESPACES: + setLamExp_NameSpaces(x, inlineNameSpaces(getLamExp_NameSpaces(x))); + break; + case LAMEXP_TYPE_LAM: + setLamExp_Lam(x, inlineLam(getLamExp_Lam(x))); + break; + case LAMEXP_TYPE_PRIM: + setLamExp_Prim(x, inlinePrim(getLamExp_Prim(x))); + break; + case LAMEXP_TYPE_SEQUENCE: + setLamExp_Sequence(x, inlineSequence(getLamExp_Sequence(x))); + break; + case LAMEXP_TYPE_MAKETUPLE: + setLamExp_MakeTuple(x, inlineArgs(getLamExp_MakeTuple(x))); + break; + case LAMEXP_TYPE_APPLY: + x = inlineApply(getLamExp_Apply(x)); + break; + case LAMEXP_TYPE_IFF: + setLamExp_Iff(x, inlineIff(getLamExp_Iff(x))); + break; + case LAMEXP_TYPE_CALLCC: + setLamExp_CallCC(x, inlineExp(getLamExp_CallCC(x))); + break; + case LAMEXP_TYPE_LETREC: + setLamExp_LetRec(x, inlineLetRec(getLamExp_LetRec(x))); + break; + case LAMEXP_TYPE_LET: + setLamExp_Let(x, inlineLet(getLamExp_Let(x))); + break; + case LAMEXP_TYPE_LETSTAR: + setLamExp_LetStar(x, inlineLetStar(getLamExp_LetStar(x))); + break; + case LAMEXP_TYPE_AMB: + setLamExp_Amb(x, inlineAmb(getLamExp_Amb(x))); + break; + case LAMEXP_TYPE_LOOKUP: + setLamExp_LookUp(x, inlineLookUp(getLamExp_LookUp(x))); + break; + case LAMEXP_TYPE_TUPLEINDEX: + setLamExp_TupleIndex(x, inlineTupleIndex(getLamExp_TupleIndex(x))); + break; + case LAMEXP_TYPE_MATCH: + setLamExp_Match(x, inlineMatch(getLamExp_Match(x))); + break; + case LAMEXP_TYPE_TAG: + setLamExp_Tag(x, inlineExp(getLamExp_Tag(x))); + break; + case LAMEXP_TYPE_DECONSTRUCT: + getLamExp_Deconstruct(x)->exp = + inlineExp(getLamExp_Deconstruct(x)->exp); + break; + case LAMEXP_TYPE_CONSTRUCTOR: + x = inlineConstant(getLamExp_Constructor(x)); + break; + case LAMEXP_TYPE_CONSTRUCT: + getLamExp_Construct(x)->args = inlineArgs(getLamExp_Construct(x)->args); + break; + case LAMEXP_TYPE_PRINT: + getLamExp_Print(x)->exp = inlineExp(getLamExp_Print(x)->exp); + getLamExp_Print(x)->printer = inlineExp(getLamExp_Print(x)->printer); + break; + case LAMEXP_TYPE_COND: + setLamExp_Cond(x, inlineCond(getLamExp_Cond(x))); + break; + case LAMEXP_TYPE_TYPEOF: + break; + default: + cant_happen("unrecognised type %s", lamExpTypeName(x->type)); } return x; } -LamExp *inlineLamExp(LamExp *x) { - return inlineExp(x); -} +LamExp *inlineLamExp(LamExp *x) { return inlineExp(x); } diff --git a/src/lambda.yaml b/src/lambda.yaml index 53c2da19..8e9931c1 100644 --- a/src/lambda.yaml +++ b/src/lambda.yaml @@ -20,81 +20,52 @@ config: name: lambda description: Plain lambda structures generated by lambda conversion. parserInfo: true + includes: + - utils.h limited_includes: - bigint.h - tc.h - tc_debug.h - lambda_functions.h - structs: LamLam: meta: brief: A lambda expression description: >- - A lambda expression is a function definition, - which can be applied to arguments. - It contains a list of variables and an expression - that forms the body of the function. If isMacro is true, + If isLazy is true, all arguments are expected to be thunked (lazy). data: - args: LamVarList + args: SymbolList exp: LamExp - isMacro: bool=false - - LamVarList: - meta: - brief: A list of variables in a lambda expression - description: >- - This structure holds a list of variables that are - bound in a lambda expression. It is used to track - the variables that are available in the scope of - the lambda. - data: - var: HashSymbol - next: LamVarList + isLazy: bool=false LamPrimApp: meta: brief: A primitive operation application - description: >- - This structure represents an application of a primitive - operation to two expressions. It is used to represent - operations like addition, subtraction, etc. data: type: LamPrimOp exp1: LamExp exp2: LamExp + replacement: LamExp=NULL LamSequence: meta: - brief: A sequence of lambda expressions - description: >- - This structure holds a sequence of lambda expressions. - It is used to represent a series of operations that are - to be executed in order. + brief: A sequence of lambda expressions e.g. (begin ...) data: exp: LamExp next: LamSequence LamArgs: meta: - brief: A list of arguments in a lambda application - description: >- - This structure holds a list of arguments that are passed - to a lambda function when it is applied. It is used to - represent the arguments in a function call. + brief: Actual arguments to a LamApply. data: exp: LamExp next: LamArgs LamApply: meta: - brief: A lambda function application - description: >- - This structure represents the application of a lambda - function to a list of arguments. It is used to apply - a function to its arguments and produce a result. + brief: A function application. data: function: LamExp args: LamArgs @@ -103,7 +74,7 @@ structs: meta: brief: A lookUp in a nameSpace description: >- - This structure represents the evaluation of an expression + Represents the evaluation of an expression in a different nameSpace. data: nsId: int @@ -112,11 +83,7 @@ structs: LamLookUpSymbol: meta: - brief: A lookUp symbol in a nameSpace - description: >- - This structure represents a symbol that is looked up - in a nameSpace. It is used to resolve symbols to their - definitions in the context of the given nameSpace. + brief: A lookUp of a symbol (constructor) in a nameSpace. data: nsId: int nsSymbol: HashSymbol @@ -125,12 +92,6 @@ structs: LamConstant: meta: brief: A constant type constructor with no arguments. - description: >- - This structure represents a constant value that is - part of a user defined type, for example `Nothing` - in the `Maybe` type. It is used to represent values - that do not have any arguments and are used as - part of a type definition. data: name: HashSymbol # the name of the constructor tag: int # the tag of the constructor @@ -138,10 +99,6 @@ structs: LamConstruct: meta: brief: A constructor application - description: >- - This structure represents the application of a constructor - to a list of arguments. It is used to create instances of - user-defined types by applying constructors to their arguments. data: name: HashSymbol # the name of the constructor tag: int # the tag of the constructor @@ -151,9 +108,7 @@ structs: meta: brief: A deconstruction of a constructor description: >- - This structure represents the deconstruction of a user-defined - type constructor. It is used to extract fields from a value - that was constructed using a specific constructor. + Used to extract fields from a constructed value. data: name: HashSymbol # name of the constructor being deconstructed nsId: int # nameSpace of the constructor being deconstructed @@ -188,11 +143,12 @@ structs: LamCond: meta: - brief: A conditional expression with multiple cases + brief: A conditional expression with multiple cases. description: >- - This structure represents a conditional expression that can - evaluate to different branches based on the value of an expression. - It is used to implement complex branching logic in the lambda expressions. + Used internally by the generated TPMC code, the cases can + be either integers (matcing type constructors) or characters + (matching literal characters). The type of the value must match + the type of the cases. data: value: LamExp cases: LamCondCases @@ -201,10 +157,7 @@ structs: meta: brief: Integer conditional cases description: >- - This structure holds a list of integer conditional cases - for a conditional expression. Each case has a constant value - and an associated body expression to be executed if the - condition matches the value. + Used internally by the generated TPMC for matching type constructor ids. data: constant: MaybeBigInt body: LamExp @@ -214,10 +167,8 @@ structs: meta: brief: Character conditional cases description: >- - This structure holds a list of character conditional cases - for a conditional expression. Each case has a constant character - and an associated body expression to be executed if the - condition matches the character. + Holds a list of character conditional cases + generated by the TPMC for matching literal characters. data: constant: character body: LamExp @@ -225,12 +176,11 @@ structs: LamMatch: meta: - brief: A pattern matching expression + brief: An integer matching expression description: >- - This structure represents a pattern matching expression that - matches an index against multiple lists of cases. Each list - of cases is associated with a body expression to be executed - if the index matches any case in the list. + Matches an integer index against multiple lists of cases. Each list + of cases is associated with a body expression to be executed on match. + Again this is generated by the TPMC. data: index: LamExp cases: LamMatchList @@ -239,10 +189,7 @@ structs: meta: brief: A list of pattern matching cases description: >- - This structure holds a list of pattern matching cases for a - match expression. Each case has a list of integers and an - associated body expression to be executed if the index matches - any integer in the list. + One set of cases in a LamMatch. data: matches: LamIntList body: LamExp @@ -252,9 +199,8 @@ structs: meta: brief: A list of integers description: >- - This structure holds a list of integers that are used in pattern - matching cases. It is used to represent the integers that are - matched against an index in a match expression. + The list of integers in a LamMatchList. + Includes a namespace id and name (why?). data: item: int name: HashSymbol @@ -264,8 +210,6 @@ structs: LamLet: meta: brief: A let expression - description: >- - A let expression allows for parallel bindings. data: bindings: LamBindings body: LamExp @@ -273,8 +217,6 @@ structs: LamLetRec: meta: brief: A letrec expression - description: >- - A letrec expression allows for recursive bindings. data: bindings: LamBindings body: LamExp @@ -282,8 +224,6 @@ structs: LamLetStar: meta: brief: A let* expression - description: >- - A let* expression allows for sequential bindings. data: bindings: LamBindings body: LamExp @@ -291,10 +231,6 @@ structs: LamBindings: meta: brief: Bindings in a let or letrec expression - description: >- - This structure holds the bindings in a let expression. - Each binding consists of a variable and an associated expression - that is evaluated in the context of the let. data: var: HashSymbol val: LamExp @@ -303,23 +239,15 @@ structs: LamContext: meta: brief: A context for lambda expressions - description: >- - This structure holds context needed for translating the AST - into a lambda expression. data: frame: LamInfoTable aliases: LamAliasTable - macros: LamMacroSet + macros: SymbolSet parent: LamContext LamAmb: meta: brief: An amb expression - description: >- - This structure represents an amb expression that allows for - non-deterministic choices in the evaluation of expressions. - It is used to implement backtracking and non-deterministic - computations. data: left: LamExp right: LamExp @@ -337,9 +265,6 @@ structs: LamTypeOf: meta: brief: A typeOf expression - description: >- - This structure represents a typeOf expression that returns - a string representation of the type of an expression. data: exp: LamExp typeString: LamExp=NULL # assgned by the type checker @@ -348,9 +273,9 @@ structs: meta: brief: Type definitions in a lambda expression description: >- - This structure holds type definitions that are used in the - lambda expressions. It is prepended to Each letrec and any - typeDefs in the AST are hoisted into this section. + This structure holds type definitions. + It is prepended to Each letrec and any + typeDefs in the letrec are hoisted into this section. data: typeDefs: LamTypeDefList body: LamExp @@ -359,30 +284,21 @@ structs: meta: brief: A list of type definitions description: >- - This structure holds a list of type definitions that are used - in the lambda expressions. Each type definition consists of a - type and its associated constructors. + contained by a LamTypeDefs structure. data: typeDef: LamTypeDef next: LamTypeDefList LamTypeDef: meta: - brief: A type definition - description: >- - This structure represents a type definition that includes - the type signature and its constructors. + brief: A single type definition data: type: LamTypeSig # re-use constructors: LamTypeConstructorList LamTypeConstructorList: meta: - brief: A list of type constructors - description: >- - This structure holds a list of type constructors that are - associated with a type definition. Each constructor has a - name and arguments. + brief: A list of type constructors forming the body of a typedef. data: constructor: LamTypeConstructor next: LamTypeConstructorList @@ -392,8 +308,7 @@ structs: brief: A type signature description: >- This structure represents a type signature that includes the - name of the type and its arguments. It is used to define the - types in the lambda expressions. + name of the type and its argument type variables. data: name: HashSymbol args: LamTypeSigArgs @@ -410,22 +325,14 @@ structs: LamTypeSigArgs: meta: - brief: Arguments for a type signature - description: >- - This structure holds the arguments for a type signature. - It is used to represent the parameters of a type in the - lambda expressions. + brief: Argument type variables for a type signature data: name: HashSymbol next: LamTypeSigArgs LamTypeConstructor: meta: - brief: A type constructor - description: >- - This structure represents a type constructor that includes - the name, type, and arguments of the constructor. It is used - to define user-defined types in the lambda expressions. + brief: A type constructor as part of a typedef. data: name: HashSymbol type: LamTypeSig @@ -433,22 +340,14 @@ structs: LamTypeConstructorArgs: meta: - brief: Arguments for a type constructor - description: >- - This structure holds the arguments for a type constructor. - It is used to represent the parameters of a type constructor - in the lambda expressions. + brief: Formal arguments for a type constructor data: arg: LamTypeConstructorType next: LamTypeConstructorArgs LamTypeFunction: meta: - brief: A type function - description: >- - This structure represents a type function that includes the - name and arguments of the function. It is used as arguments - to type constructors during their definition. + brief: A type function as a formal argument to a type constructor data: name: LamLookUpOrSymbol args: LamTypeConstructorArgs @@ -456,10 +355,6 @@ structs: LamTypeConstructorInfo: meta: brief: Information about a type constructor - description: >- - This utility structure collects information about a type - constructor, including its name, nameSpace, type, tags, - and arity. data: name: HashSymbol nsId: int @@ -470,19 +365,6 @@ structs: size: int # number of alternatives index: int # index into list of alternatives - LamAlphaEnv: - meta: - brief: An environment for alpha conversion - description: >- - This structure holds the environment needed for alpha - conversion of lambda expressions. It includes an alpha - table for tracking variable substitutions and a parent - environment for nested scopes. - parserInfo: false - data: - alphaTable: LamAlphaTable - next: LamAlphaEnv - nameSpaces: LamAlphaEnvArray=NULL enums: LamPrimOp: meta: @@ -507,10 +389,6 @@ unions: LamExp: meta: brief: A lambda expression - description: >- - This union represents the different types of expressions that can - be evaluated in the lambda expressions. It includes function - applications, variable lookUps, constants, and various operations. data: amb: LamAmb apply: LamApply @@ -551,7 +429,7 @@ unions: meta: brief: A lookUp or symbol in a nameSpace description: >- - This union represents either a lookUp of a symbol in a + Represents either a lookUp of a symbol in a nameSpace or a symbol in the current nameSpace. data: symbol: HashSymbol @@ -559,11 +437,7 @@ unions: LamCondCases: meta: - brief: Conditional cases for a lambda expression - description: >- - This union holds the cases for a conditional expression. - It can contain either integer or character cases, each with - their own associated body expressions. + brief: Cases for a LamCond data: integers: LamIntCondCases characters: LamCharCondCases @@ -572,9 +446,8 @@ unions: meta: brief: A type constructor type description: >- - This union represents the different types of arguments that can - be passed to a type constructor. It includes integers, characters, - variables, functions, and tuples. + Defines the different types of arguments that can + be passed to a type constructor. data: integer: void_ptr character: void_ptr @@ -585,31 +458,12 @@ unions: LamInfo: meta: brief: Information about a symbol - description: >- - This union holds information about a symbol, - depending on its type. data: typeConstructorInfo: LamTypeConstructorInfo nameSpaceInfo: LamContext nsId: int hashes: - LamMacroSet: - meta: - brief: the set of symbols that are currently defined as macros - description: >- - This table holds the symbols that are bound to macros in the - current context. - data: {} - - LamMacroArgsSet: - meta: - brief: the set of symbols that are currently defined as macro arguments - description: >- - This table holds the symbols that are bound to macro arguments - in the current context (body of the macro). - data: {} - LamInfoTable: meta: brief: Map from symbols to information about them @@ -621,8 +475,6 @@ hashes: LamAliasTable: meta: brief: Map from symbols to their types in the body of a type constructor. - description: >- - This table holds the types for symbols in the current context. data: entries: LamTypeConstructorType @@ -636,15 +488,6 @@ hashes: data: entries: LamExp - LamAlphaTable: - meta: - brief: Map from symbols to their substitutes - description: >- - Table for alpha conversion, mapping from original symbols - to their substituted symbols. - data: - entries: HashSymbol - arrays: LamNameSpaceArray: meta: @@ -655,20 +498,8 @@ arrays: data: entries: LamExp - LamAlphaEnvArray: - meta: - brief: An array of alpha conversion environments - description: >- - This array holds the alpha conversion environments per-nameSpace. - data: - entries: LamAlphaEnv - primitives: !include primitives.yaml external: - TcType: - data: - cname: "struct TcType *" - printFn: printTcType - markFn: markTcType - valued: true +- !include tc.yaml +- !include utils.yaml \ No newline at end of file diff --git a/src/lambda_alphaconvert.c b/src/lambda_alphaconvert.c index 47817242..292f0679 100644 --- a/src/lambda_alphaconvert.c +++ b/src/lambda_alphaconvert.c @@ -1,17 +1,17 @@ /* * CEKF - VM supporting amb * Copyright (C) 2022-2025 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 . * @@ -19,242 +19,112 @@ * Generated from src/lambda.yaml by tools/generate.py */ -#include "lambda.h" #include "common.h" #include "memory.h" +#include "minlam.h" +#include "minlam_pp.h" #include "symbol.h" -#include "lambda_pp.h" +#include "utils.h" #include "lambda_alphaconvert.h" // Forward declarations -static LamMacroSet *visitLamMacroSet(LamMacroSet *node, LamAlphaEnv *context); -static LamMacroArgsSet *visitLamMacroArgsSet(LamMacroArgsSet *node, LamAlphaEnv *context); -static LamInfoTable *visitLamInfoTable(LamInfoTable *node, LamAlphaEnv *context); -static LamAliasTable *visitLamAliasTable(LamAliasTable *node, LamAlphaEnv *context); -static LamExpTable *visitLamExpTable(LamExpTable *node, LamAlphaEnv *context); -static LamLam *visitLamLam(LamLam *node, LamAlphaEnv *context); -static LamVarList *visitLamVarList(LamVarList *node, LamAlphaEnv *context); -static LamPrimApp *visitLamPrimApp(LamPrimApp *node, LamAlphaEnv *context); -static LamSequence *visitLamSequence(LamSequence *node, LamAlphaEnv *context); -static LamArgs *visitLamArgs(LamArgs *node, LamAlphaEnv *context); -static LamApply *visitLamApply(LamApply *node, LamAlphaEnv *context); -static LamLookUp *visitLamLookUp(LamLookUp *node, LamAlphaEnv *context); -static LamLookUpSymbol *visitLamLookUpSymbol(LamLookUpSymbol *node, LamAlphaEnv *context); -static LamConstant *visitLamConstant(LamConstant *node, LamAlphaEnv *context); -static LamConstruct *visitLamConstruct(LamConstruct *node, LamAlphaEnv *context); -static LamDeconstruct *visitLamDeconstruct(LamDeconstruct *node, LamAlphaEnv *context); -static LamTupleIndex *visitLamTupleIndex(LamTupleIndex *node, LamAlphaEnv *context); -static LamMakeVec *visitLamMakeVec(LamMakeVec *node, LamAlphaEnv *context); -static LamIff *visitLamIff(LamIff *node, LamAlphaEnv *context); -static LamCond *visitLamCond(LamCond *node, LamAlphaEnv *context); -static LamIntCondCases *visitLamIntCondCases(LamIntCondCases *node, LamAlphaEnv *context); -static LamCharCondCases *visitLamCharCondCases(LamCharCondCases *node, LamAlphaEnv *context); -static LamMatch *visitLamMatch(LamMatch *node, LamAlphaEnv *context); -static LamMatchList *visitLamMatchList(LamMatchList *node, LamAlphaEnv *context); -static LamIntList *visitLamIntList(LamIntList *node, LamAlphaEnv *context); -static LamLetStar *visitLamLetStar(LamLetStar *node, LamAlphaEnv *context); -static LamLet *visitLamLet(LamLet *node, LamAlphaEnv *context); -static LamBindings *visitLetBindings(LamBindings *node, LamAlphaEnv *context); -static LamBindings *visitLetStarBindings(LamBindings *node, LamAlphaEnv *context); -static LamLetRec *visitLamLetRec(LamLetRec *node, LamAlphaEnv *context); -static LamContext *visitLamContext(LamContext *node, LamAlphaEnv *context); -static LamAmb *visitLamAmb(LamAmb *node, LamAlphaEnv *context); -static LamPrint *visitLamPrint(LamPrint *node, LamAlphaEnv *context); -static LamTypeOf *visitLamTypeOf(LamTypeOf *node, LamAlphaEnv *context); -static LamTypeDefs *visitLamTypeDefs(LamTypeDefs *node, LamAlphaEnv *context); -static LamTypeDefList *visitLamTypeDefList(LamTypeDefList *node, LamAlphaEnv *context); -static LamTypeDef *visitLamTypeDef(LamTypeDef *node, LamAlphaEnv *context); -static LamTypeConstructorList *visitLamTypeConstructorList(LamTypeConstructorList *node, LamAlphaEnv *context); -static LamTypeSig *visitLamTypeSig(LamTypeSig *node, LamAlphaEnv *context); -static LamTypeTags *visitLamTypeTags(LamTypeTags *node, LamAlphaEnv *context); -static LamTypeSigArgs *visitLamTypeSigArgs(LamTypeSigArgs *node, LamAlphaEnv *context); -static LamTypeConstructor *visitLamTypeConstructor(LamTypeConstructor *node, LamAlphaEnv *context); -static LamTypeConstructorArgs *visitLamTypeConstructorArgs(LamTypeConstructorArgs *node, LamAlphaEnv *context); -static LamTypeFunction *visitLamTypeFunction(LamTypeFunction *node, LamAlphaEnv *context); -static LamTypeConstructorInfo *visitLamTypeConstructorInfo(LamTypeConstructorInfo *node, LamAlphaEnv *context); -static LamExp *visitLamExp(LamExp *node, LamAlphaEnv *context); -static LamLookUpOrSymbol *visitLamLookUpOrSymbol(LamLookUpOrSymbol *node, LamAlphaEnv *context); -static LamCondCases *visitLamCondCases(LamCondCases *node, LamAlphaEnv *context); -static LamTypeConstructorType *visitLamTypeConstructorType(LamTypeConstructorType *node, LamAlphaEnv *context); -static LamInfo *visitLamInfo(LamInfo *node, LamAlphaEnv *context); -static LamNameSpaceArray *visitLamNameSpaceArray(LamNameSpaceArray *node, LamAlphaEnv *context); +static MinLam *visitMinLam(MinLam *node, MinAlphaEnv *context); +static SymbolList *visitMinVarList(SymbolList *node, MinAlphaEnv *context); +static MinPrimApp *visitMinPrimApp(MinPrimApp *node, MinAlphaEnv *context); +static MinExprList *visitMinSequence(MinExprList *node, MinAlphaEnv *context); +static MinExprList *visitMinArgs(MinExprList *node, MinAlphaEnv *context); +static MinApply *visitMinApply(MinApply *node, MinAlphaEnv *context); +static MinLookUp *visitMinLookUp(MinLookUp *node, MinAlphaEnv *context); +static MinExprList *visitMinMakeVec(MinExprList *node, MinAlphaEnv *context); +static MinIff *visitMinIff(MinIff *node, MinAlphaEnv *context); +static MinCond *visitMinCond(MinCond *node, MinAlphaEnv *context); +static MinIntCondCases *visitMinIntCondCases(MinIntCondCases *node, + MinAlphaEnv *context); +static MinCharCondCases *visitMinCharCondCases(MinCharCondCases *node, + MinAlphaEnv *context); +static MinMatch *visitMinMatch(MinMatch *node, MinAlphaEnv *context); +static MinMatchList *visitMinMatchList(MinMatchList *node, + MinAlphaEnv *context); +static MinIntList *visitMinIntList(MinIntList *node, MinAlphaEnv *context); +static MinLetRec *visitMinLetRec(MinLetRec *node, MinAlphaEnv *context); +static MinAmb *visitMinAmb(MinAmb *node, MinAlphaEnv *context); +static MinExp *visitMinExp(MinExp *node, MinAlphaEnv *context); +static MinCondCases *visitMinCondCases(MinCondCases *node, + MinAlphaEnv *context); +static MinNameSpaceArray *visitMinNameSpaceArray(MinNameSpaceArray *node, + MinAlphaEnv *context); int alpha_flag = 0; char *alpha_conversion_function = NULL; -static void addUniqueNameToContext(HashSymbol *name, LamAlphaEnv *context) { +static void addUniqueNameToContext(HashSymbol *name, MinAlphaEnv *context) { #ifdef SAFETY_CHECKS if (context == NULL) { cant_happen("NULL context"); } #endif HashSymbol *newName = genSymDollar(name->name); - setLamAlphaTable(context->alphaTable, name, newName); + setSymbolMap(context->alphaTable, name, newName); } -static HashSymbol *getNameFromContext(ParserInfo PI, HashSymbol *name, LamAlphaEnv *context) { +static HashSymbol *getNameFromContext(ParserInfo PI, HashSymbol *name, + MinAlphaEnv *context) { struct HashSymbol *mappedName = NULL; while (context != NULL) { - if (getLamAlphaTable(context->alphaTable, name, &mappedName)) { + if (getSymbolMap(context->alphaTable, name, &mappedName)) { return mappedName; } context = context->next; } - cant_happen("undefined variable %s [%s +%d]", name->name, PI.fileName, PI.lineNo); + cant_happen("undefined variable %s [%s +%d]", name->name, PI.fileName, + PI.lineNo); } -static void pushNameSpaceEnv(LamAlphaEnv *context) { - for (LamAlphaEnv *current = context; current != NULL; current = current->next) { +static void pushNameSpaceEnv(MinAlphaEnv *context) { + for (MinAlphaEnv *current = context; current != NULL; + current = current->next) { if (current->nameSpaces != NULL) { - pushLamAlphaEnvArray(current->nameSpaces, context); + pushMinAlphaEnvArray(current->nameSpaces, context); return; } } cant_happen("no nameSpace array found in context"); } -static LamAlphaEnv *findAlphaNameSpaceEnv(LamAlphaEnv *context, Index index) { - for (LamAlphaEnv *current = context; current != NULL; current = current->next) { +static MinAlphaEnv *findAlphaNameSpaceEnv(MinAlphaEnv *context, Index index) { + for (MinAlphaEnv *current = context; current != NULL; + current = current->next) { if (current->nameSpaces != NULL) { if (index < current->nameSpaces->size) { return current->nameSpaces->entries[index]; } else { - cant_happen("index %u out of bounds (size %u)", index, current->nameSpaces->size); + cant_happen("index %u out of bounds (size %u)", index, + current->nameSpaces->size); } } } cant_happen("no nameSpace array found in context"); } -// Visitor implementations -static LamMacroSet *visitLamMacroSet(LamMacroSet *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - (void)context; // Hash set has no values to visit - // Iterate over keys (uncomment if you need to inspect/log them) - // Index i = 0; - // HashSymbol *key; - // while ((key = iterateLamMacroSet(node, &i)) != NULL) { - // // Inspect/log key here - // } - return node; -} - -__attribute__((unused)) -static LamMacroArgsSet *visitLamMacroArgsSet(LamMacroArgsSet *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - (void)context; // Hash set has no values to visit - // Iterate over keys (uncomment if you need to inspect/log them) - // Index i = 0; - // HashSymbol *key; - // while ((key = iterateLamMacroArgsSet(node, &i)) != NULL) { - // // Inspect/log key here - // } - return node; -} - -static LamInfoTable *visitLamInfoTable(LamInfoTable *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamInfoTable *result = newLamInfoTable(); - int save = PROTECT(result); - - // Iterate over all entries - Index i = 0; - struct LamInfo * value; - HashSymbol *key; - while ((key = iterateLamInfoTable(node, &i, &value)) != NULL) { - struct LamInfo * new_value = visitLamInfo(value, context); - PROTECT(new_value); - changed = changed || (new_value != value); - setLamInfoTable(result, key, new_value); - } - - if (changed) { - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamAliasTable *visitLamAliasTable(LamAliasTable *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamAliasTable *result = newLamAliasTable(); - int save = PROTECT(result); - - // Iterate over all entries - Index i = 0; - struct LamTypeConstructorType * value; - HashSymbol *key; - while ((key = iterateLamAliasTable(node, &i, &value)) != NULL) { - struct LamTypeConstructorType * new_value = visitLamTypeConstructorType(value, context); - PROTECT(new_value); - changed = changed || (new_value != value); - setLamAliasTable(result, key, new_value); - } - - if (changed) { - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -__attribute__((unused)) -static LamExpTable *visitLamExpTable(LamExpTable *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamExpTable *result = newLamExpTable(); - int save = PROTECT(result); - - // Iterate over all entries - Index i = 0; - struct LamExp * value; - HashSymbol *key; - while ((key = iterateLamExpTable(node, &i, &value)) != NULL) { - struct LamExp * new_value = visitLamExp(value, context); - PROTECT(new_value); - changed = changed || (new_value != value); - setLamExpTable(result, key, new_value); - } - - if (changed) { - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamLam *visitLamLam(LamLam *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinLam *visitMinLam(MinLam *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; - context = newLamAlphaEnv(context); + context = newMinAlphaEnv(context); int save = PROTECT(context); bool changed = false; - LamVarList *args = visitLamVarList(node->args, context); + SymbolList *args = visitMinVarList(node->args, context); PROTECT(args); changed = changed || (args != node->args); - LamExp *new_exp = visitLamExp(node->exp, context); + MinExp *new_exp = visitMinExp(node->exp, context); PROTECT(new_exp); changed = changed || (new_exp != node->exp); if (changed) { // Create new node with modified fields - LamLam *result = newLamLam(CPI(node), args, new_exp); - result->isMacro = node->isMacro; + MinLam *result = newMinLam(CPI(node), args, new_exp); UNPROTECT(save); return result; } @@ -263,34 +133,38 @@ static LamLam *visitLamLam(LamLam *node, LamAlphaEnv *context) { return node; } -static LamVarList *visitLamVarList(LamVarList *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static SymbolList *visitMinVarList(SymbolList *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; - LamVarList *next = visitLamVarList(node->next, context); + SymbolList *next = visitMinVarList(node->next, context); int save = PROTECT(next); - addUniqueNameToContext(node->var, context); + addUniqueNameToContext(node->symbol, context); - LamVarList *result = newLamVarList(CPI(node), getNameFromContext(CPI(node), node->var, context), next); + SymbolList *result = newSymbolList( + CPI(node), getNameFromContext(CPI(node), node->symbol, context), next); UNPROTECT(save); return result; } -static LamPrimApp *visitLamPrimApp(LamPrimApp *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinPrimApp *visitMinPrimApp(MinPrimApp *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - // Pass through type (type: LamPrimOp, not memory-managed) - LamExp *new_exp1 = visitLamExp(node->exp1, context); + // Pass through type (type: MinPrimOp, not memory-managed) + MinExp *new_exp1 = visitMinExp(node->exp1, context); int save = PROTECT(new_exp1); changed = changed || (new_exp1 != node->exp1); - LamExp *new_exp2 = visitLamExp(node->exp2, context); + MinExp *new_exp2 = visitMinExp(node->exp2, context); PROTECT(new_exp2); changed = changed || (new_exp2 != node->exp2); if (changed) { // Create new node with modified fields - LamPrimApp *result = newLamPrimApp(CPI(node), node->type, new_exp1, new_exp2); + MinPrimApp *result = + newMinPrimApp(CPI(node), node->type, new_exp1, new_exp2); UNPROTECT(save); return result; } @@ -299,20 +173,21 @@ static LamPrimApp *visitLamPrimApp(LamPrimApp *node, LamAlphaEnv *context) { return node; } -static LamSequence *visitLamSequence(LamSequence *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinExprList *visitMinSequence(MinExprList *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamExp *new_exp = visitLamExp(node->exp, context); + MinExp *new_exp = visitMinExp(node->exp, context); int save = PROTECT(new_exp); changed = changed || (new_exp != node->exp); - LamSequence *new_next = visitLamSequence(node->next, context); + MinExprList *new_next = visitMinSequence(node->next, context); PROTECT(new_next); changed = changed || (new_next != node->next); if (changed) { // Create new node with modified fields - LamSequence *result = newLamSequence(CPI(node), new_exp, new_next); + MinExprList *result = newMinExprList(CPI(node), new_exp, new_next); UNPROTECT(save); return result; } @@ -321,20 +196,21 @@ static LamSequence *visitLamSequence(LamSequence *node, LamAlphaEnv *context) { return node; } -static LamArgs *visitLamArgs(LamArgs *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinExprList *visitMinArgs(MinExprList *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamExp *new_exp = visitLamExp(node->exp, context); + MinExp *new_exp = visitMinExp(node->exp, context); int save = PROTECT(new_exp); changed = changed || (new_exp != node->exp); - LamArgs *new_next = visitLamArgs(node->next, context); + MinExprList *new_next = visitMinArgs(node->next, context); PROTECT(new_next); changed = changed || (new_next != node->next); if (changed) { // Create new node with modified fields - LamArgs *result = newLamArgs(CPI(node), new_exp, new_next); + MinExprList *result = newMinExprList(CPI(node), new_exp, new_next); UNPROTECT(save); return result; } @@ -343,84 +219,24 @@ static LamArgs *visitLamArgs(LamArgs *node, LamAlphaEnv *context) { return node; } -static LamApply *visitLamApply(LamApply *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinApply *visitMinApply(MinApply *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamExp *new_function = visitLamExp(node->function, context); + MinExp *new_function = visitMinExp(node->function, context); int save = PROTECT(new_function); if (new_function == NULL) { - cant_happen("visitLamApply: function is NULL"); + cant_happen("visitMinApply: function is NULL"); } changed = changed || (new_function != node->function); - LamArgs *new_args = visitLamArgs(node->args, context); + MinExprList *new_args = visitMinArgs(node->args, context); PROTECT(new_args); changed = changed || (new_args != node->args); if (changed) { // Create new node with modified fields - LamApply *result = newLamApply(CPI(node), new_function, new_args); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamLookUp *visitLamLookUp(LamLookUp *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamAlphaEnv *nsContext = findAlphaNameSpaceEnv(context, node->nsId); - LamExp *new_exp = visitLamExp(node->exp, nsContext); - int save = PROTECT(new_exp); - changed = changed || (new_exp != node->exp); - - if (changed) { - LamLookUp *result = newLamLookUp(CPI(node), node->nsId, node->nsSymbol, new_exp); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamLookUpSymbol *visitLamLookUpSymbol(LamLookUpSymbol *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - // Pass through nsId (type: int, not memory-managed) - // Pass through nsSymbol (type: HashSymbol, not memory-managed) - // Pass through symbol (type: HashSymbol, not memory-managed) - - (void)context; // Unused parameter - all fields are pass-through - return node; -} - -static LamConstant *visitLamConstant(LamConstant *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - // Pass through name (type: HashSymbol, not memory-managed) - // Pass through tag (type: int, not memory-managed) - - (void)context; // Unused parameter - all fields are pass-through - return node; -} - -static LamConstruct *visitLamConstruct(LamConstruct *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through name (type: HashSymbol, not memory-managed) - // Pass through tag (type: int, not memory-managed) - LamArgs *new_args = visitLamArgs(node->args, context); - int save = PROTECT(new_args); - changed = changed || (new_args != node->args); - - if (changed) { - // Create new node with modified fields - LamConstruct *result = newLamConstruct(CPI(node), node->name, node->tag, new_args); + MinApply *result = newMinApply(CPI(node), new_function, new_args); UNPROTECT(save); return result; } @@ -429,41 +245,18 @@ static LamConstruct *visitLamConstruct(LamConstruct *node, LamAlphaEnv *context) return node; } -static LamDeconstruct *visitLamDeconstruct(LamDeconstruct *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through name (type: HashSymbol, not memory-managed) - // Pass through nsId (type: int, not memory-managed) - // Pass through vec (type: int, not memory-managed) - LamExp *new_exp = visitLamExp(node->exp, context); - int save = PROTECT(new_exp); - changed = changed || (new_exp != node->exp); - - if (changed) { - // Create new node with modified fields - LamDeconstruct *result = newLamDeconstruct(CPI(node), node->name, node->nsId, node->vec, new_exp); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTupleIndex *visitLamTupleIndex(LamTupleIndex *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinLookUp *visitMinLookUp(MinLookUp *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - // Pass through vec (type: int, not memory-managed) - // Pass through size (type: int, not memory-managed) - LamExp *new_exp = visitLamExp(node->exp, context); + MinAlphaEnv *nsContext = findAlphaNameSpaceEnv(context, node->nsId); + MinExp *new_exp = visitMinExp(node->exp, nsContext); int save = PROTECT(new_exp); changed = changed || (new_exp != node->exp); if (changed) { - // Create new node with modified fields - LamTupleIndex *result = newLamTupleIndex(CPI(node), node->vec, node->size, new_exp); + MinLookUp *result = newMinLookUp(CPI(node), node->nsId, new_exp); UNPROTECT(save); return result; } @@ -472,43 +265,32 @@ static LamTupleIndex *visitLamTupleIndex(LamTupleIndex *node, LamAlphaEnv *conte return node; } -static LamMakeVec *visitLamMakeVec(LamMakeVec *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through nArgs (type: int, not memory-managed) - LamArgs *new_args = visitLamArgs(node->args, context); - int save = PROTECT(new_args); - changed = changed || (new_args != node->args); - - if (changed) { - // Create new node with modified fields - LamMakeVec *result = newLamMakeVec(CPI(node), node->nArgs, new_args); - UNPROTECT(save); - return result; - } +static MinExprList *visitMinMakeVec(MinExprList *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; - UNPROTECT(save); - return node; + return visitMinArgs(node, context); } -static LamIff *visitLamIff(LamIff *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinIff *visitMinIff(MinIff *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamExp *new_condition = visitLamExp(node->condition, context); + MinExp *new_condition = visitMinExp(node->condition, context); int save = PROTECT(new_condition); changed = changed || (new_condition != node->condition); - LamExp *new_consequent = visitLamExp(node->consequent, context); + MinExp *new_consequent = visitMinExp(node->consequent, context); PROTECT(new_consequent); changed = changed || (new_consequent != node->consequent); - LamExp *new_alternative = visitLamExp(node->alternative, context); + MinExp *new_alternative = visitMinExp(node->alternative, context); PROTECT(new_alternative); changed = changed || (new_alternative != node->alternative); if (changed) { // Create new node with modified fields - LamIff *result = newLamIff(CPI(node), new_condition, new_consequent, new_alternative); + MinIff *result = newMinIff(CPI(node), new_condition, new_consequent, + new_alternative); UNPROTECT(save); return result; } @@ -517,20 +299,21 @@ static LamIff *visitLamIff(LamIff *node, LamAlphaEnv *context) { return node; } -static LamCond *visitLamCond(LamCond *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinCond *visitMinCond(MinCond *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamExp *new_value = visitLamExp(node->value, context); + MinExp *new_value = visitMinExp(node->value, context); int save = PROTECT(new_value); changed = changed || (new_value != node->value); - LamCondCases *new_cases = visitLamCondCases(node->cases, context); + MinCondCases *new_cases = visitMinCondCases(node->cases, context); PROTECT(new_cases); changed = changed || (new_cases != node->cases); if (changed) { // Create new node with modified fields - LamCond *result = newLamCond(CPI(node), new_value, new_cases); + MinCond *result = newMinCond(CPI(node), new_value, new_cases); UNPROTECT(save); return result; } @@ -539,21 +322,24 @@ static LamCond *visitLamCond(LamCond *node, LamAlphaEnv *context) { return node; } -static LamIntCondCases *visitLamIntCondCases(LamIntCondCases *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinIntCondCases *visitMinIntCondCases(MinIntCondCases *node, + MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; // Pass through constant (type: MaybeBigInt, not memory-managed) - LamExp *new_body = visitLamExp(node->body, context); + MinExp *new_body = visitMinExp(node->body, context); int save = PROTECT(new_body); changed = changed || (new_body != node->body); - LamIntCondCases *new_next = visitLamIntCondCases(node->next, context); + MinIntCondCases *new_next = visitMinIntCondCases(node->next, context); PROTECT(new_next); changed = changed || (new_next != node->next); if (changed) { // Create new node with modified fields - LamIntCondCases *result = newLamIntCondCases(CPI(node), node->constant, new_body, new_next); + MinIntCondCases *result = + newMinIntCondCases(CPI(node), node->constant, new_body, new_next); UNPROTECT(save); return result; } @@ -562,21 +348,24 @@ static LamIntCondCases *visitLamIntCondCases(LamIntCondCases *node, LamAlphaEnv return node; } -static LamCharCondCases *visitLamCharCondCases(LamCharCondCases *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinCharCondCases *visitMinCharCondCases(MinCharCondCases *node, + MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; // Pass through constant (type: character, not memory-managed) - LamExp *new_body = visitLamExp(node->body, context); + MinExp *new_body = visitMinExp(node->body, context); int save = PROTECT(new_body); changed = changed || (new_body != node->body); - LamCharCondCases *new_next = visitLamCharCondCases(node->next, context); + MinCharCondCases *new_next = visitMinCharCondCases(node->next, context); PROTECT(new_next); changed = changed || (new_next != node->next); if (changed) { // Create new node with modified fields - LamCharCondCases *result = newLamCharCondCases(CPI(node), node->constant, new_body, new_next); + MinCharCondCases *result = + newMinCharCondCases(CPI(node), node->constant, new_body, new_next); UNPROTECT(save); return result; } @@ -585,20 +374,21 @@ static LamCharCondCases *visitLamCharCondCases(LamCharCondCases *node, LamAlphaE return node; } -static LamMatch *visitLamMatch(LamMatch *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinMatch *visitMinMatch(MinMatch *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamExp *new_index = visitLamExp(node->index, context); + MinExp *new_index = visitMinExp(node->index, context); int save = PROTECT(new_index); changed = changed || (new_index != node->index); - LamMatchList *new_cases = visitLamMatchList(node->cases, context); + MinMatchList *new_cases = visitMinMatchList(node->cases, context); PROTECT(new_cases); changed = changed || (new_cases != node->cases); if (changed) { // Create new node with modified fields - LamMatch *result = newLamMatch(CPI(node), new_index, new_cases); + MinMatch *result = newMinMatch(CPI(node), new_index, new_cases); UNPROTECT(save); return result; } @@ -607,23 +397,26 @@ static LamMatch *visitLamMatch(LamMatch *node, LamAlphaEnv *context) { return node; } -static LamMatchList *visitLamMatchList(LamMatchList *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinMatchList *visitMinMatchList(MinMatchList *node, + MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamIntList *new_matches = visitLamIntList(node->matches, context); + MinIntList *new_matches = visitMinIntList(node->matches, context); int save = PROTECT(new_matches); changed = changed || (new_matches != node->matches); - LamExp *new_body = visitLamExp(node->body, context); + MinExp *new_body = visitMinExp(node->body, context); PROTECT(new_body); changed = changed || (new_body != node->body); - LamMatchList *new_next = visitLamMatchList(node->next, context); + MinMatchList *new_next = visitMinMatchList(node->next, context); PROTECT(new_next); changed = changed || (new_next != node->next); if (changed) { // Create new node with modified fields - LamMatchList *result = newLamMatchList(CPI(node), new_matches, new_body, new_next); + MinMatchList *result = + newMinMatchList(CPI(node), new_matches, new_body, new_next); UNPROTECT(save); return result; } @@ -632,20 +425,21 @@ static LamMatchList *visitLamMatchList(LamMatchList *node, LamAlphaEnv *context) return node; } -static LamIntList *visitLamIntList(LamIntList *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinIntList *visitMinIntList(MinIntList *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; // Pass through item (type: int, not memory-managed) // Pass through name (type: HashSymbol, not memory-managed) // Pass through nsId (type: int, not memory-managed) - LamIntList *new_next = visitLamIntList(node->next, context); + MinIntList *new_next = visitMinIntList(node->next, context); int save = PROTECT(new_next); changed = changed || (new_next != node->next); if (changed) { // Create new node with modified fields - LamIntList *result = newLamIntList(CPI(node), node->item, node->name, node->nsId, new_next); + MinIntList *result = newMinIntList(CPI(node), node->item, new_next); UNPROTECT(save); return result; } @@ -654,350 +448,66 @@ static LamIntList *visitLamIntList(LamIntList *node, LamAlphaEnv *context) { return node; } -static LamLet *visitLamLet(LamLet *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - context = newLamAlphaEnv(context); - int save = PROTECT(context); - bool changed = false; - LamBindings *new_bindings = visitLetBindings(node->bindings, context); - PROTECT(new_bindings); - changed = changed || (new_bindings != node->bindings); - LamExp *new_body = visitLamExp(node->body, context); - PROTECT(new_body); - changed = changed || (new_body != node->body); - if (changed) { - // Create new node with modified fields - LamLet *result = newLamLet(CPI(node), new_bindings, new_body); - UNPROTECT(save); - return result; - } - UNPROTECT(save); - return node; -} - -static LamBindings *visitLetBindings(LamBindings *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - LamExp *new_val = visitLamExp(node->val, context); - int save = PROTECT(new_val); - LamBindings *new_next = visitLetBindings(node->next, context); - PROTECT(new_next); - addUniqueNameToContext(node->var, context); - // Create new node with modified fields - LamBindings *result = newLamBindings(CPI(node), getNameFromContext(CPI(node), node->var, context), new_val, new_next); - UNPROTECT(save); - return result; -} - -static LamLetStar *visitLamLetStar(LamLetStar *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - context = newLamAlphaEnv(context); - int save = PROTECT(context); - bool changed = false; - LamBindings *new_bindings = visitLetStarBindings(node->bindings, context); - PROTECT(new_bindings); - changed = changed || (new_bindings != node->bindings); - LamExp *new_body = visitLamExp(node->body, context); - PROTECT(new_body); - changed = changed || (new_body != node->body); - if (changed) { - // Create new node with modified fields - LamLetStar *result = newLamLetStar(CPI(node), new_bindings, new_body); - UNPROTECT(save); - return result; - } - UNPROTECT(save); - return node; -} - -static LamBindings *visitLetStarBindings(LamBindings *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - LamExp *new_val = visitLamExp(node->val, context); - int save = PROTECT(new_val); - addUniqueNameToContext(node->var, context); - LamBindings *new_next = visitLetStarBindings(node->next, context); - PROTECT(new_next); - // Create new node with modified fields - LamBindings *result = newLamBindings(CPI(node), getNameFromContext(CPI(node), node->var, context), new_val, new_next); - UNPROTECT(save); - return result; -} - -static LamBindings *visitLetRecValues(LamBindings *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - LamExp *new_val = visitLamExp(node->val, context); +static MinBindings *visitLetRecValues(MinBindings *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; + MinExp *new_val = visitMinExp(node->val, context); int save = PROTECT(new_val); if (alpha_conversion_function != NULL && strcmp(alpha_conversion_function, node->var->name) == 0) { - ppLamExp(new_val); - eprintf("\n"); + ppMinExp(new_val); + eprintf("\n"); } - LamBindings *new_next = visitLetRecValues(node->next, context); + MinBindings *new_next = visitLetRecValues(node->next, context); PROTECT(new_next); - LamBindings *result = newLamBindings(CPI(node), getNameFromContext(CPI(node), node->var, context), new_val, new_next); + MinBindings *result = newMinBindings( + CPI(node), getNameFromContext(CPI(node), node->var, context), new_val, + new_next); UNPROTECT(save); return result; } -static void visitLetRecVariables(LamBindings *node, LamAlphaEnv *context) { - if (node == NULL) return; +static void visitLetRecVariables(MinBindings *node, MinAlphaEnv *context) { + if (node == NULL) + return; visitLetRecVariables(node->next, context); addUniqueNameToContext(node->var, context); } -static LamLetRec *visitLamLetRec(LamLetRec *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinLetRec *visitMinLetRec(MinLetRec *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; - context = newLamAlphaEnv(context); + context = newMinAlphaEnv(context); int save = PROTECT(context); visitLetRecVariables(node->bindings, context); - LamBindings *new_bindings = visitLetRecValues(node->bindings, context); + MinBindings *new_bindings = visitLetRecValues(node->bindings, context); PROTECT(new_bindings); - LamExp *new_body = visitLamExp(node->body, context); + MinExp *new_body = visitMinExp(node->body, context); PROTECT(new_body); // Create new node with modified fields - LamLetRec *result = newLamLetRec(CPI(node), new_bindings, new_body); + MinLetRec *result = newMinLetRec(CPI(node), new_bindings, new_body); UNPROTECT(save); return result; } -static LamContext *visitLamContext(LamContext *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamInfoTable *new_frame = visitLamInfoTable(node->frame, context); - int save = PROTECT(new_frame); - changed = changed || (new_frame != node->frame); - LamAliasTable *new_aliases = visitLamAliasTable(node->aliases, context); - PROTECT(new_aliases); - changed = changed || (new_aliases != node->aliases); - LamMacroSet *new_macros = visitLamMacroSet(node->macros, context); - PROTECT(new_macros); - changed = changed || (new_macros != node->macros); - LamContext *new_parent = visitLamContext(node->parent, context); - PROTECT(new_parent); - changed = changed || (new_parent != node->parent); - - if (changed) { - // Create new node with modified fields - LamContext *result = newLamContext(CPI(node), new_parent); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamAmb *visitLamAmb(LamAmb *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinAmb *visitMinAmb(MinAmb *node, MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamExp *new_left = visitLamExp(node->left, context); + MinExp *new_left = visitMinExp(node->left, context); int save = PROTECT(new_left); changed = changed || (new_left != node->left); - LamExp *new_right = visitLamExp(node->right, context); + MinExp *new_right = visitMinExp(node->right, context); PROTECT(new_right); changed = changed || (new_right != node->right); if (changed) { // Create new node with modified fields - LamAmb *result = newLamAmb(CPI(node), new_left, new_right); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamPrint *visitLamPrint(LamPrint *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamExp *new_exp = visitLamExp(node->exp, context); - int save = PROTECT(new_exp); - changed = changed || (new_exp != node->exp); - LamExp *new_printer = visitLamExp(node->printer, context); - PROTECT(new_printer); - changed = changed || (new_printer != node->printer); - - if (changed) { - // Create new node with modified fields - LamPrint *result = newLamPrint(CPI(node), new_exp); - result->printer = new_printer; - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeOf *visitLamTypeOf(LamTypeOf *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamExp *new_exp = visitLamExp(node->exp, context); - int save = PROTECT(new_exp); - changed = changed || (new_exp != node->exp); - LamExp *new_typeString = visitLamExp(node->typeString, context); - PROTECT(new_typeString); - changed = changed || (new_typeString != node->typeString); - - if (changed) { - // Create new node with modified fields - LamTypeOf *result = newLamTypeOf(CPI(node), new_exp); - result->typeString = new_typeString; - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeDefs *visitLamTypeDefs(LamTypeDefs *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamTypeDefList *new_typeDefs = visitLamTypeDefList(node->typeDefs, context); - int save = PROTECT(new_typeDefs); - changed = changed || (new_typeDefs != node->typeDefs); - LamExp *new_body = visitLamExp(node->body, context); - PROTECT(new_body); - changed = changed || (new_body != node->body); - - if (changed) { - // Create new node with modified fields - LamTypeDefs *result = newLamTypeDefs(CPI(node), new_typeDefs, new_body); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeDefList *visitLamTypeDefList(LamTypeDefList *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamTypeDef *new_typeDef = visitLamTypeDef(node->typeDef, context); - int save = PROTECT(new_typeDef); - changed = changed || (new_typeDef != node->typeDef); - LamTypeDefList *new_next = visitLamTypeDefList(node->next, context); - PROTECT(new_next); - changed = changed || (new_next != node->next); - - if (changed) { - // Create new node with modified fields - LamTypeDefList *result = newLamTypeDefList(CPI(node), new_typeDef, new_next); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeDef *visitLamTypeDef(LamTypeDef *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamTypeSig *new_type = visitLamTypeSig(node->type, context); - int save = PROTECT(new_type); - changed = changed || (new_type != node->type); - LamTypeConstructorList *new_constructors = visitLamTypeConstructorList(node->constructors, context); - PROTECT(new_constructors); - changed = changed || (new_constructors != node->constructors); - - if (changed) { - // Create new node with modified fields - LamTypeDef *result = newLamTypeDef(CPI(node), new_type, new_constructors); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeConstructorList *visitLamTypeConstructorList(LamTypeConstructorList *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamTypeConstructor *new_constructor = visitLamTypeConstructor(node->constructor, context); - int save = PROTECT(new_constructor); - changed = changed || (new_constructor != node->constructor); - LamTypeConstructorList *new_next = visitLamTypeConstructorList(node->next, context); - PROTECT(new_next); - changed = changed || (new_next != node->next); - - if (changed) { - // Create new node with modified fields - LamTypeConstructorList *result = newLamTypeConstructorList(CPI(node), new_constructor, new_next); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeSig *visitLamTypeSig(LamTypeSig *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through name (type: HashSymbol, not memory-managed) - LamTypeSigArgs *new_args = visitLamTypeSigArgs(node->args, context); - int save = PROTECT(new_args); - changed = changed || (new_args != node->args); - - if (changed) { - // Create new node with modified fields - LamTypeSig *result = newLamTypeSig(CPI(node), node->name, new_args); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeTags *visitLamTypeTags(LamTypeTags *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through tag (type: HashSymbol, not memory-managed) - LamTypeTags *new_next = visitLamTypeTags(node->next, context); - int save = PROTECT(new_next); - changed = changed || (new_next != node->next); - - if (changed) { - // Create new node with modified fields - LamTypeTags *result = newLamTypeTags(CPI(node), node->tag, new_next); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeSigArgs *visitLamTypeSigArgs(LamTypeSigArgs *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through name (type: HashSymbol, not memory-managed) - LamTypeSigArgs *new_next = visitLamTypeSigArgs(node->next, context); - int save = PROTECT(new_next); - changed = changed || (new_next != node->next); - - if (changed) { - // Create new node with modified fields - LamTypeSigArgs *result = newLamTypeSigArgs(CPI(node), node->name, new_next); + MinAmb *result = newMinAmb(CPI(node), new_left, new_right); UNPROTECT(save); return result; } @@ -1006,586 +516,263 @@ static LamTypeSigArgs *visitLamTypeSigArgs(LamTypeSigArgs *node, LamAlphaEnv *co return node; } -static LamTypeConstructor *visitLamTypeConstructor(LamTypeConstructor *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through name (type: HashSymbol, not memory-managed) - LamTypeSig *new_type = visitLamTypeSig(node->type, context); - int save = PROTECT(new_type); - changed = changed || (new_type != node->type); - LamTypeConstructorArgs *new_args = visitLamTypeConstructorArgs(node->args, context); - PROTECT(new_args); - changed = changed || (new_args != node->args); - - if (changed) { - // Create new node with modified fields - LamTypeConstructor *result = newLamTypeConstructor(CPI(node), node->name, new_type, new_args); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeConstructorArgs *visitLamTypeConstructorArgs(LamTypeConstructorArgs *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamTypeConstructorType *new_arg = visitLamTypeConstructorType(node->arg, context); - int save = PROTECT(new_arg); - changed = changed || (new_arg != node->arg); - LamTypeConstructorArgs *new_next = visitLamTypeConstructorArgs(node->next, context); - PROTECT(new_next); - changed = changed || (new_next != node->next); - - if (changed) { - // Create new node with modified fields - LamTypeConstructorArgs *result = newLamTypeConstructorArgs(CPI(node), new_arg, new_next); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeFunction *visitLamTypeFunction(LamTypeFunction *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - LamLookUpOrSymbol *new_name = visitLamLookUpOrSymbol(node->name, context); - int save = PROTECT(new_name); - changed = changed || (new_name != node->name); - LamTypeConstructorArgs *new_args = visitLamTypeConstructorArgs(node->args, context); - PROTECT(new_args); - changed = changed || (new_args != node->args); - - if (changed) { - // Create new node with modified fields - LamTypeFunction *result = newLamTypeFunction(CPI(node), new_name, new_args); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamTypeConstructorInfo *visitLamTypeConstructorInfo(LamTypeConstructorInfo *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - bool changed = false; - // Pass through name (type: HashSymbol, not memory-managed) - // Pass through nsId (type: int, not memory-managed) - LamTypeConstructor *new_type = visitLamTypeConstructor(node->type, context); - int save = PROTECT(new_type); - changed = changed || (new_type != node->type); - LamTypeTags *new_tags = visitLamTypeTags(node->tags, context); - PROTECT(new_tags); - changed = changed || (new_tags != node->tags); - // Pass through needsVec (type: bool, not memory-managed) - // Pass through arity (type: int, not memory-managed) - // Pass through size (type: int, not memory-managed) - // Pass through index (type: int, not memory-managed) - - if (changed) { - // Create new node with modified fields - LamTypeConstructorInfo *result = newLamTypeConstructorInfo(CPI(node), node->name, node->nsId, new_type, new_tags, node->needsVec, node->arity, node->size, node->index); - UNPROTECT(save); - return result; - } - - UNPROTECT(save); - return node; -} - -static LamExp *visitLamExp(LamExp *node, LamAlphaEnv *context) { +static MinExp *visitMinExp(MinExp *node, MinAlphaEnv *context) { if (node == NULL) { return NULL; } - LamExp *result = node; + MinExp *result = node; int save = PROTECT(result); switch (node->type) { - case LAMEXP_TYPE_AMB: { - // LamAmb - LamAmb *variant = getLamExp_Amb(node); - LamAmb *new_variant = visitLamAmb(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Amb(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_APPLY: { - // LamApply - LamApply *variant = getLamExp_Apply(node); - LamApply *new_variant = visitLamApply(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Apply(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_ARGS: { - // LamArgs - LamArgs *variant = getLamExp_Args(node); - LamArgs *new_variant = visitLamArgs(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Args(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_BACK: { - // void_ptr - break; - } - case LAMEXP_TYPE_BIGINTEGER: { - // MaybeBigInt - break; - } - case LAMEXP_TYPE_BINDINGS: { - // LamBindings - cant_happen("LamExp of type BINDINGS should not occur in the wild"); - break; - } - case LAMEXP_TYPE_CALLCC: { - // LamExp - LamExp *variant = getLamExp_CallCC(node); - LamExp *new_variant = visitLamExp(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_CallCC(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_CHARACTER: { - // character - break; - } - case LAMEXP_TYPE_COND: { - // LamCond - LamCond *variant = getLamExp_Cond(node); - LamCond *new_variant = visitLamCond(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Cond(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_CONSTANT: { - // LamConstant - LamConstant *variant = getLamExp_Constant(node); - LamConstant *new_variant = visitLamConstant(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Constant(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_CONSTRUCT: { - // LamConstruct - LamConstruct *variant = getLamExp_Construct(node); - LamConstruct *new_variant = visitLamConstruct(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Construct(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_CONSTRUCTOR: { - // LamTypeConstructorInfo - LamTypeConstructorInfo *variant = getLamExp_Constructor(node); - LamTypeConstructorInfo *new_variant = visitLamTypeConstructorInfo(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Constructor(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_DECONSTRUCT: { - // LamDeconstruct - LamDeconstruct *variant = getLamExp_Deconstruct(node); - LamDeconstruct *new_variant = visitLamDeconstruct(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Deconstruct(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_ENV: { - // void_ptr - // the `(env)` directive is a way of capturing the current - // environment from the "body" of a nameSpace. - // It is a generated instruction and cannot be written - // directly in source code. - // It must be the only expression in the nameSpace body and - // it can only appear there. It is an instruction - // that the current environment should be - // associated with the current nameSpace at this point. - pushNameSpaceEnv(context); - break; - } - case LAMEXP_TYPE_ERROR: { - // void_ptr - break; - } - case LAMEXP_TYPE_IFF: { - // LamIff - LamIff *variant = getLamExp_Iff(node); - LamIff *new_variant = visitLamIff(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Iff(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_LAM: { - // LamLam - LamLam *variant = getLamExp_Lam(node); - LamLam *new_variant = visitLamLam(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Lam(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_LET: { - // LamLet - LamLet *variant = getLamExp_Let(node); - LamLet *new_variant = visitLamLet(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Let(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_LETSTAR: { - // LamLetStar - LamLetStar *variant = getLamExp_LetStar(node); - LamLetStar *new_variant = visitLamLetStar(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_LetStar(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_LETREC: { - // LamLetRec - LamLetRec *variant = getLamExp_LetRec(node); - LamLetRec *new_variant = visitLamLetRec(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_LetRec(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_LOOKUP: { - // LamLookUp - LamLookUp *variant = getLamExp_LookUp(node); - LamLookUp *new_variant = visitLamLookUp(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_LookUp(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_MAKETUPLE: { - // LamArgs - LamArgs *variant = getLamExp_MakeTuple(node); - LamArgs *new_variant = visitLamArgs(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_MakeTuple(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_MAKEVEC: { - // LamMakeVec - LamMakeVec *variant = getLamExp_MakeVec(node); - LamMakeVec *new_variant = visitLamMakeVec(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_MakeVec(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_MATCH: { - // LamMatch - LamMatch *variant = getLamExp_Match(node); - LamMatch *new_variant = visitLamMatch(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Match(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_NAMESPACES: { - // LamNameSpaceArray - LamNameSpaceArray *variant = getLamExp_NameSpaces(node); - LamNameSpaceArray *new_variant = visitLamNameSpaceArray(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_NameSpaces(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_PRIM: { - // LamPrimApp - LamPrimApp *variant = getLamExp_Prim(node); - LamPrimApp *new_variant = visitLamPrimApp(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Prim(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_PRINT: { - // LamPrint - LamPrint *variant = getLamExp_Print(node); - LamPrint *new_variant = visitLamPrint(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Print(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_SEQUENCE: { - // LamSequence - LamSequence *variant = getLamExp_Sequence(node); - LamSequence *new_variant = visitLamSequence(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Sequence(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_STDINT: { - // int - break; - } - case LAMEXP_TYPE_TAG: { - // LamExp - LamExp *variant = getLamExp_Tag(node); - LamExp *new_variant = visitLamExp(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_Tag(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_TUPLEINDEX: { - // LamTupleIndex - LamTupleIndex *variant = getLamExp_TupleIndex(node); - LamTupleIndex *new_variant = visitLamTupleIndex(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_TupleIndex(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_TYPEDEFS: { - // LamTypeDefs - LamTypeDefs *variant = getLamExp_TypeDefs(node); - LamTypeDefs *new_variant = visitLamTypeDefs(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_TypeDefs(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_TYPEOF: { - // LamTypeOf - LamTypeOf *variant = getLamExp_TypeOf(node); - LamTypeOf *new_variant = visitLamTypeOf(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamExp_TypeOf(CPI(node), new_variant); - } - break; - } - case LAMEXP_TYPE_VAR: { - // HashSymbol - result = newLamExp_Var(CPI(node), getNameFromContext(CPI(node), getLamExp_Var(node), context)); - break; - } - default: - cant_happen("unrecognized LamExp type %s", lamExpTypeName(node->type)); + case MINEXP_TYPE_AMB: { + // MinAmb + MinAmb *variant = getMinExp_Amb(node); + MinAmb *new_variant = visitMinAmb(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 = visitMinApply(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Apply(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_ARGS: { + // MinExprList + MinExprList *variant = getMinExp_Args(node); + MinExprList *new_variant = visitMinArgs(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Args(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_BACK: { + // void_ptr + break; + } + case MINEXP_TYPE_BIGINTEGER: { + // MaybeBigInt + break; + } + case MINEXP_TYPE_BINDINGS: { + // MinBindings + cant_happen("MinExp of type BINDINGS should not occur in the wild"); + break; + } + case MINEXP_TYPE_CALLCC: { + // MinExp + MinExp *variant = getMinExp_CallCC(node); + MinExp *new_variant = visitMinExp(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 = visitMinCond(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cond(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_ENV: { + // void_ptr + // the `(env)` directive is a way of capturing the current + // environment from the "body" of a nameSpace. + // It is a generated instruction and cannot be written + // directly in source code. + // It must be the only expression in the nameSpace body and + // it can only appear there. It is an instruction + // that the current environment should be + // associated with the current nameSpace at this point. + pushNameSpaceEnv(context); + break; + } + case MINEXP_TYPE_ERROR: { + // void_ptr + break; + } + case MINEXP_TYPE_IFF: { + // MinIff + MinIff *variant = getMinExp_Iff(node); + MinIff *new_variant = visitMinIff(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 = visitMinLam(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 = visitMinLetRec(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 = visitMinLookUp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_LookUp(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_MAKEVEC: { + // MinMakeVec + MinExprList *variant = getMinExp_MakeVec(node); + MinExprList *new_variant = visitMinMakeVec(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 = visitMinMatch(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 = + visitMinNameSpaceArray(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 = visitMinPrimApp(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 = visitMinSequence(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: { + // HashSymbol + result = newMinExp_Var( + CPI(node), + getNameFromContext(CPI(node), getMinExp_Var(node), context)); + break; + } + default: + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } UNPROTECT(save); return result; } -static LamLookUpOrSymbol *visitLamLookUpOrSymbol(LamLookUpOrSymbol *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - int save = PROTECT(NULL); - LamLookUpOrSymbol *result = node; - - switch (node->type) { - case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: { - // HashSymbol - break; - } - case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: { - // LamLookUpSymbol - LamLookUpSymbol *variant = getLamLookUpOrSymbol_LookUp(node); - LamLookUpSymbol *new_variant = visitLamLookUpSymbol(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamLookUpOrSymbol_LookUp(CPI(node), new_variant); - } - break; - } - default: - cant_happen("unrecognized LamLookUpOrSymbol type %d", node->type); - } - - UNPROTECT(save); - return result; -} - -static LamCondCases *visitLamCondCases(LamCondCases *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinCondCases *visitMinCondCases(MinCondCases *node, + MinAlphaEnv *context) { + if (node == NULL) + return NULL; int save = PROTECT(NULL); - LamCondCases *result = node; + MinCondCases *result = node; switch (node->type) { - case LAMCONDCASES_TYPE_INTEGERS: { - // LamIntCondCases - LamIntCondCases *variant = getLamCondCases_Integers(node); - LamIntCondCases *new_variant = visitLamIntCondCases(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamCondCases_Integers(CPI(node), new_variant); - } - break; - } - case LAMCONDCASES_TYPE_CHARACTERS: { - // LamCharCondCases - LamCharCondCases *variant = getLamCondCases_Characters(node); - LamCharCondCases *new_variant = visitLamCharCondCases(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamCondCases_Characters(CPI(node), new_variant); - } - break; + case MINCONDCASES_TYPE_INTEGERS: { + // MinIntCondCases + MinIntCondCases *variant = getMinCondCases_Integers(node); + MinIntCondCases *new_variant = visitMinIntCondCases(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Integers(CPI(node), new_variant); } - default: - cant_happen("unrecognized LamCondCases type %d", node->type); + break; } - - UNPROTECT(save); - return result; -} - -static LamTypeConstructorType *visitLamTypeConstructorType(LamTypeConstructorType *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - int save = PROTECT(NULL); - LamTypeConstructorType *result = node; - - switch (node->type) { - case LAMTYPECONSTRUCTORTYPE_TYPE_INTEGER: { - // void_ptr - break; - } - case LAMTYPECONSTRUCTORTYPE_TYPE_CHARACTER: { - // void_ptr - break; - } - case LAMTYPECONSTRUCTORTYPE_TYPE_VAR: { - // HashSymbol - break; - } - case LAMTYPECONSTRUCTORTYPE_TYPE_FUNCTION: { - // LamTypeFunction - LamTypeFunction *variant = getLamTypeConstructorType_Function(node); - LamTypeFunction *new_variant = visitLamTypeFunction(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamTypeConstructorType_Function(CPI(node), new_variant); - } - break; - } - case LAMTYPECONSTRUCTORTYPE_TYPE_TUPLE: { - // LamTypeConstructorArgs - LamTypeConstructorArgs *variant = getLamTypeConstructorType_Tuple(node); - LamTypeConstructorArgs *new_variant = visitLamTypeConstructorArgs(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamTypeConstructorType_Tuple(CPI(node), new_variant); - } - break; + case MINCONDCASES_TYPE_CHARACTERS: { + // MinCharCondCases + MinCharCondCases *variant = getMinCondCases_Characters(node); + MinCharCondCases *new_variant = visitMinCharCondCases(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinCondCases_Characters(CPI(node), new_variant); } - default: - cant_happen("unrecognized LamTypeConstructorType type %d", node->type); + break; } - - UNPROTECT(save); - return result; -} - -static LamInfo *visitLamInfo(LamInfo *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; - - int save = PROTECT(NULL); - LamInfo *result = node; - - switch (node->type) { - case LAMINFO_TYPE_TYPECONSTRUCTORINFO: { - // LamTypeConstructorInfo - LamTypeConstructorInfo *variant = getLamInfo_TypeConstructorInfo(node); - LamTypeConstructorInfo *new_variant = visitLamTypeConstructorInfo(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamInfo_TypeConstructorInfo(CPI(node), new_variant); - } - break; - } - case LAMINFO_TYPE_NAMESPACEINFO: { - // LamContext - LamContext *variant = getLamInfo_NameSpaceInfo(node); - LamContext *new_variant = visitLamContext(variant, context); - if (new_variant != variant) { - PROTECT(new_variant); - result = newLamInfo_NameSpaceInfo(CPI(node), new_variant); - } - break; - } - case LAMINFO_TYPE_NSID: { - // int - break; - } - default: - cant_happen("unrecognized LamInfo type %d", node->type); + default: + cant_happen("unrecognized MinCondCases type %d", node->type); } UNPROTECT(save); return result; } -static LamNameSpaceArray *visitLamNameSpaceArray(LamNameSpaceArray *node, LamAlphaEnv *context) { - if (node == NULL) return NULL; +static MinNameSpaceArray *visitMinNameSpaceArray(MinNameSpaceArray *node, + MinAlphaEnv *context) { + if (node == NULL) + return NULL; bool changed = false; - LamNameSpaceArray *result = newLamNameSpaceArray(); + MinNameSpaceArray *result = newMinNameSpaceArray(); int save = PROTECT(result); - context->nameSpaces = newLamAlphaEnvArray(); + context->nameSpaces = newMinAlphaEnvArray(); // Iterate over all elements for (Index i = 0; i < node->size; i++) { - struct LamExp * element = peeknLamNameSpaceArray(node, i); - struct LamExp * new_element = visitLamExp(element, context); + struct MinExp *element = peeknMinNameSpaceArray(node, i); + struct MinExp *new_element = visitMinExp(element, context); PROTECT(new_element); changed = changed || (new_element != element); - pushLamNameSpaceArray(result, new_element); + pushMinNameSpaceArray(result, new_element); } if (changed) { @@ -1597,18 +784,19 @@ static LamNameSpaceArray *visitLamNameSpaceArray(LamNameSpaceArray *node, LamAlp return node; } -static void addBuiltInsToLamAlphaEnv(LamAlphaEnv *env, BuiltIns *b) { +static void addBuiltInsToMinAlphaEnv(MinAlphaEnv *env, BuiltIns *b) { for (Index i = 0; i < b->size; i++) { // Bind only internal names; external names are provided by wrappers. - setLamAlphaTable(env->alphaTable, b->entries[i]->internalName, b->entries[i]->internalName); + setSymbolMap(env->alphaTable, b->entries[i]->internalName, + b->entries[i]->internalName); } } -LamExp *alphaConvertLamExp(LamExp *exp, BuiltIns *builtIns) { - LamAlphaEnv *env = newLamAlphaEnv(NULL); +MinExp *alphaConvertMinExp(MinExp *exp, BuiltIns *builtIns) { + MinAlphaEnv *env = newMinAlphaEnv(NULL); int save = PROTECT(env); - addBuiltInsToLamAlphaEnv(env, builtIns); - LamExp *result = visitLamExp(exp, env); + addBuiltInsToMinAlphaEnv(env, builtIns); + MinExp *result = visitMinExp(exp, env); UNPROTECT(save); return result; } \ No newline at end of file diff --git a/src/lambda_alphaconvert.h b/src/lambda_alphaconvert.h index 9316a286..98467011 100644 --- a/src/lambda_alphaconvert.h +++ b/src/lambda_alphaconvert.h @@ -1,25 +1,25 @@ #ifndef cekf_lambda_alphaconvert_h -# define cekf_lambda_alphaconvert_h +#define cekf_lambda_alphaconvert_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2025 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 "builtins.h" -LamExp *alphaConvertLamExp(LamExp *exp, BuiltIns *builtIns); +MinExp *alphaConvertMinExp(MinExp *exp, BuiltIns *builtIns); extern int alpha_flag; extern char *alpha_conversion_function; diff --git a/src/lambda_conversion.c b/src/lambda_conversion.c index a89284bd..5e75d93c 100644 --- a/src/lambda_conversion.c +++ b/src/lambda_conversion.c @@ -18,66 +18,63 @@ /** * @file lambda_conversion.c - * + * * conversion of the AST generated by the parser * to an intermediate "plain" lambda calculus which * will then be fed into the type checker and the * A-Normal Form converter. */ +#include #include #include -#include + +#include "ast_debug.h" #include "common.h" #include "lambda_conversion.h" -#include "macro_substitution.h" #include "lambda_helper.h" +#include "lazy_substitution.h" +#include "pratt_scanner.h" +#include "print_generator.h" #include "symbols.h" #include "tpmc_logic.h" #include "tpmc_mermaid.h" -#include "ast_debug.h" -#include "print_generator.h" +#include "utils.h" char *lambda_conversion_function = NULL; // set by --dump-lambda flag static LamBindings *convertFuncDefs(AstDefinitions *, LamContext *); static LamArgs *convertExpressions(AstExpressions *, LamContext *); static LamSequence *convertSequence(AstExpressions *, LamContext *); -static LamBindings *prependDefinition(AstDefinition *, LamContext *, LamBindings *); +static LamBindings *prependDefinition(AstDefinition *, LamContext *, + LamBindings *); static LamBindings *prependDefine(AstDefine *, LamContext *, LamBindings *); static LamExp *convertExpression(AstExpression *, LamContext *); static bool typeHasFields(AstTypeBody *); static LamTypeDefList *collectTypeDefs(AstDefinitions *, LamContext *); static void collectAliases(AstDefinitions *, LamContext *); -static LamTypeConstructor *convertTypeConstructor(AstTypeConstructor *, LamTypeSig *, int, int, bool, LamContext *); -static void collectTypeInfo(HashSymbol *, AstTypeConstructorArgs *, LamTypeConstructor *, bool, int, int, int, LamContext *); +static LamTypeConstructor *convertTypeConstructor(AstTypeConstructor *, + LamTypeSig *, int, int, bool, + LamContext *); +static void collectTypeInfo(HashSymbol *, AstTypeConstructorArgs *, + LamTypeConstructor *, bool, int, int, int, + LamContext *); static LamTypeConstructorArgs *convertAstTypeList(AstTypeList *, LamContext *); static LamTypeConstructorArgs *convertAstTypeMap(AstTypeMap *, LamContext *); -static LamTypeConstructorArgs *convertAstTypeConstructorArgs(AstTypeConstructorArgs *, LamContext *); +static LamTypeConstructorArgs * +convertAstTypeConstructorArgs(AstTypeConstructorArgs *, LamContext *); static LamExp *convertNest(AstNest *, LamContext *); -static LamExp *lamConvert(AstDefinitions *, AstNameSpaceArray *, AstExpressions *, LamContext *); +static LamExp *lamConvert(AstDefinitions *, AstNameSpaceArray *, + AstExpressions *, LamContext *, bool isNameSpaceBody); static LamExp *convertSymbol(ParserInfo, HashSymbol *, LamContext *); static LamExp *convertAnnotatedSymbol(AstAnnotatedSymbol *, LamContext *); #ifdef DEBUG_LAMBDA_CONVERT -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif -static void conversionError(ParserInfo, char *, ...) __attribute__((format(printf, 2, 3))); - -/** - * @brief Report an error in the lambda conversion. - */ -static void conversionError(ParserInfo I, char *message, ...) { - va_list args; - va_start(args, message); - vfprintf(errout, message, args); - va_end(args); - can_happen(" at +%d %s", I.lineNo, I.fileName); -} - /** * @brief Creates a value that can be returned in the case of an error */ @@ -87,7 +84,7 @@ static LamExp *lamExpError(ParserInfo I) { /** * @brief Adds the current nameSpace to the lambda context. - * + * * Adds the `$nameSpace` symbol to the current context, bound to the * current nameSpace id. * @@ -103,7 +100,8 @@ static void addCurrentNameSpaceToContext(LamContext *context, int nameSpaceId) { } /** - * @brief Creates an AstDefinitions node for currentFile with the given fileName. + * @brief Creates an AstDefinitions node for currentFile with the given + * fileName. * * This creates a definition: let currentFile = "fileName"; ... * as an AST node that can be prepended to the preamble. @@ -113,13 +111,15 @@ static void addCurrentNameSpaceToContext(LamContext *context, int nameSpaceId) { * @param next The next AstDefinitions in the list. * @return An AstDefinitions node containing the currentFile definition. */ -static AstDefinitions *makeCurrentFileDefinition(const char *fileName, ParserInfo PI, AstDefinitions *next) { +static AstDefinitions *makeCurrentFileDefinition(const char *fileName, + ParserInfo PI, + AstDefinitions *next) { // Build a string as nested cons applications, starting with nil AstExpression *nil = newAstExpression_Symbol(PI, nilSymbol()); int save = PROTECT(nil); AstFunCall *strList = newAstFunCall(PI, nil, NULL); PROTECT(strList); - + // Build the string from right to left (reverse order) for (int i = strlen(fileName) - 1; i >= 0; i--) { AstExpression *character = newAstExpression_Character(PI, fileName[i]); @@ -136,17 +136,15 @@ static AstDefinitions *makeCurrentFileDefinition(const char *fileName, ParserInf REPLACE_PROTECT(save, strList); UNPROTECT(save2); } - + AstExpression *stringExpr = newAstExpression_FunCall(PI, strList); PROTECT(stringExpr); - + // Create the definition: currentFile = "..." - AstDefine *define = newAstDefine(PI, currentFileSymbol(), stringExpr); - PROTECT(define); - - AstDefinition *definition = newAstDefinition_Define(PI, define); + AstDefinition *definition = + makeAstDefinition_Define(PI, currentFileSymbol(), stringExpr); PROTECT(definition); - + AstDefinitions *result = newAstDefinitions(PI, definition, next); UNPROTECT(save); return result; @@ -166,13 +164,14 @@ LamExp *lamConvertProg(AstProg *prog) { LamContext *env = newLamContext(CPI(prog), NULL); int save = PROTECT(env); addCurrentNameSpaceToContext(env, NS_GLOBAL); - + // Prepend currentFile definition to preamble - AstDefinitions *preambleWithCurrentFile = - makeCurrentFileDefinition(prog->_yy_parser_info.fileName, CPI(prog), prog->preamble); + AstDefinitions *preambleWithCurrentFile = makeCurrentFileDefinition( + prog->_yy_parser_info.fileName, CPI(prog), prog->preamble); PROTECT(preambleWithCurrentFile); - - LamExp *result = lamConvert(preambleWithCurrentFile, prog->nameSpaces, prog->body, env); + + LamExp *result = lamConvert(preambleWithCurrentFile, prog->nameSpaces, + prog->body, env, false); UNPROTECT(save); LEAVE(lamConvertProg); return result; @@ -189,7 +188,8 @@ static LamExp *convertNest(AstNest *nest, LamContext *env) { ENTER(convertNest); env = newLamContext(CPI(nest), env); int save = PROTECT(env); - LamExp *result = lamConvert(nest->definitions, NULL, nest->expressions, env); + LamExp *result = + lamConvert(nest->definitions, NULL, nest->expressions, env, false); PROTECT(result); UNPROTECT(save); LEAVE(convertNest); @@ -216,16 +216,18 @@ static void addConstructorInfoToLamContext(LamContext *context, /** * @brief Adds nameSpace information to the lambda context. * - * The information stored is the context resulting from converting the AST nameSpace. - * That context is stored against a key generated from the nameSpace id (so it is recoverable). - * The key contains non-alphanumeric characters so it cannot conflict with identifiers in the AST. + * The information stored is the context resulting from converting the AST + * nameSpace. That context is stored against a key generated from the nameSpace + * id (so it is recoverable). The key contains non-alphanumeric characters so it + * cannot conflict with identifiers in the AST. * * @param context The lambda context to modify. * @param info The lambda context of the nameSpace. * @param nameSpace The ID of the nameSpace. * @return void */ -static void addNameSpaceInfoToLamContext(LamContext *context, LamContext *info, Index nameSpace) { +static void addNameSpaceInfoToLamContext(LamContext *context, LamContext *info, + Index nameSpace) { char buf[80]; sprintf(buf, NS_FORMAT, nameSpace); // ns$%u HashSymbol *symbol = newSymbol(buf); @@ -236,20 +238,20 @@ static void addNameSpaceInfoToLamContext(LamContext *context, LamContext *info, } /** - * @brief converts a nameSpace and pushes it on to the growing lambda nameSpace array. - * + * @brief converts a nameSpace and pushes it on to the growing lambda nameSpace + * array. + * * IMPORTANT: this function also adds the nameSpace info to the parent context. * * @param nsArray The AST nameSpace array to retrieve the nameSpace from. * @param i The index of the nameSpace in the array. * @param env The lambda context to use. - * @param nameSpaces The lambda nameSpace array to push the converted nameSpace into. + * @param nameSpaces The lambda nameSpace array to push the converted nameSpace + * into. * @return void */ -static void convertNameSpace(AstNameSpaceArray *nsArray, - Index i, - LamContext *env, - LamNameSpaceArray *nameSpaces) { +static void convertNameSpace(AstNameSpaceArray *nsArray, Index i, + LamContext *env, LamNameSpaceArray *nameSpaces) { AstNameSpaceImpl *nameSpace = nsArray->entries[i]; LamContext *nsEnv = newLamContext(CPI(env), env); int save2 = PROTECT(nsEnv); @@ -258,24 +260,25 @@ static void convertNameSpace(AstNameSpaceArray *nsArray, PROTECT(envToken); AstExpressions *body = newAstExpressions(CPI(nameSpace), envToken, NULL); PROTECT(body); - LamExp *lamNameSpace = lamConvert(nameSpace->definitions, NULL, body, nsEnv); + LamExp *lamNameSpace = + lamConvert(nameSpace->definitions, NULL, body, nsEnv, true); PROTECT(lamNameSpace); pushLamNameSpaceArray(nameSpaces, lamNameSpace); addNameSpaceInfoToLamContext(env, nsEnv, i); UNPROTECT(save2); } -static void separateLambdas(LamBindings *funcDefs, - LamBindings **lambdas, - LamBindings **other) -{ +static void separateLambdas(LamBindings *funcDefs, LamBindings **lambdas, + LamBindings **other) { if (funcDefs != NULL) { separateLambdas(funcDefs->next, lambdas, other); if (funcDefs->val->type == LAMEXP_TYPE_LAM) { - *lambdas = newLamBindings(CPI(funcDefs), funcDefs->var, funcDefs->val, *lambdas); + *lambdas = newLamBindings(CPI(funcDefs), funcDefs->var, + funcDefs->val, *lambdas); PROTECT(*lambdas); } else { - *other = newLamBindings(CPI(funcDefs), funcDefs->var, funcDefs->val, *other); + *other = newLamBindings(CPI(funcDefs), funcDefs->var, funcDefs->val, + *other); PROTECT(*other); } } @@ -299,8 +302,8 @@ static void appendLamBindings(LamBindings **lambdas, LamBindings **other) { * @param funcDefs The letrec bindings to hoist. * @return The resulting letrec bindings with functions hoisted to the front. */ -__attribute__((unused)) -static LamBindings *hoistFunctionDefinitions(LamBindings *funcDefs) { +__attribute__((unused)) static LamBindings * +hoistFunctionDefinitions(LamBindings *funcDefs) { int save = PROTECT(funcDefs); LamBindings *lambdas = NULL; LamBindings *other = NULL; @@ -311,18 +314,20 @@ static LamBindings *hoistFunctionDefinitions(LamBindings *funcDefs) { } /** - * @brief Workhorse routine that converts various nest-like scenarios to a common LamExp + * @brief Workhorse routine that converts various nest-like scenarios to a + * common LamExp * * @param definitions If there were definitions. - * @param nsArray nameSpaces collected during parsing to be converted and attached + * @param nsArray nameSpaces collected during parsing to be converted and + * attached * @param expressions The AST expressions to convert. * @param env The lambda context to use. * @return The resulting lambda expression. */ static LamExp *lamConvert(AstDefinitions *definitions, AstNameSpaceArray *nsArray, - AstExpressions *expressions, - LamContext *env) { + AstExpressions *expressions, LamContext *env, + bool isNameSpaceBody) { ENTER(lamConvert); // record aliases in env @@ -346,6 +351,17 @@ static LamExp *lamConvert(AstDefinitions *definitions, // defsList = hoistFunctionDefinitions(defsList); // PROTECT(defsList); + // namespaces can only contain function definitions, not variable bindings + // (because bytecode for non-lambda letrec entries skips NS_END) + if (varDefsList != NULL && isNameSpaceBody) { + for (LamBindings *b = varDefsList; b != NULL; b = b->next) { + can_happen(CPI(b), + "namespaces cannot contain non-function bindings: '%s' " + "(you can wrap data in functions that return it)", + b->var->name); + } + } + // prepend print functions: // [printers] [funcs] // [vars] @@ -363,8 +379,8 @@ static LamExp *lamConvert(AstDefinitions *definitions, } // convert the body sequence - // MUST be done *after* converting the nameSpaces so they are available in env - // [body expressions] + // MUST be done *after* converting the nameSpaces so they are available in + // env [body expressions] LamSequence *body = convertSequence(expressions, env); PROTECT(body); @@ -376,23 +392,28 @@ static LamExp *lamConvert(AstDefinitions *definitions, body = newLamSequence(CPI(env), lamNameSpaces, body); PROTECT(body); } - + // promote the body sequence to a LamExp // [[nameSpaces] [body]] - LamExp *letRecBody = (body == NULL) ? NULL : newLamExp_Sequence(CPI(body), body); + LamExp *letRecBody = + (body == NULL) ? NULL : newLamExp_Sequence(CPI(body), body); PROTECT(letRecBody); LamExp *result = NULL; if (varDefsList != NULL) { // prepend variable definitions to the letrec body // [vars] [[nameSpaces] [body]] - letRecBody = makeLamExp_LetStar(CPI(varDefsList), varDefsList, letRecBody); + letRecBody = + makeLamExp_LetStar(CPI(varDefsList), varDefsList, letRecBody); PROTECT(letRecBody); } // if there are functions, create a letrec, else just use the body if (funcDefsList != NULL) { // [[printers] [funcs] [vars] [[nameSpaces] [body]]] - result = (letRecBody == NULL) ? NULL : makeLamExp_LetRec(CPI(letRecBody), funcDefsList, letRecBody); + result = + (letRecBody == NULL) + ? NULL + : makeLamExp_LetRec(CPI(letRecBody), funcDefsList, letRecBody); } else { // [vars] [[nameSpaces] [body]] result = letRecBody; @@ -451,7 +472,8 @@ static LamExp *lamConvertPrint(AstPrint *print, LamContext *context) { } /** - * @brief Converts an AST TypeOf Expression to a lambda expression that returns the type as a string. + * @brief Converts an AST TypeOf Expression to a lambda expression that returns + * the type as a string. * * @param typeOfExp The AST TypeOf Expression to convert. * @param context The lambda context to use. @@ -461,22 +483,22 @@ static LamExp *lamConvertTypeOf(AstTypeOf *typeOfExp, LamContext *context) { ENTER(lamConvertTypeOf); LamExp *exp = convertExpression(typeOfExp->exp, context); int save = PROTECT(exp); - LamTypeOf *lamTypeOf = newLamTypeOf(CPI(exp), exp); - PROTECT(lamTypeOf); - LamExp *result = newLamExp_TypeOf(CPI(lamTypeOf), lamTypeOf); + LamExp *result = makeLamExp_TypeOf(CPI(exp), exp); UNPROTECT(save); LEAVE(lamConvertTypeOf); return result; } /** - * @brief Converts an AST Tuple Expression to a lambda expression that constructs a tuple. + * @brief Converts an AST Tuple Expression to a lambda expression that + * constructs a tuple. * * @param tuple The Tuple Expression to convert. * @param env The lambda context to use. * @return The resulting lambda expression. */ -static LamExp *lamConvertTuple(ParserInfo PI, AstExpressions *tuple, LamContext *env) { +static LamExp *lamConvertTuple(ParserInfo PI, AstExpressions *tuple, + LamContext *env) { LamArgs *expressions = convertExpressions(tuple, env); int save = PROTECT(expressions); LamExp *res = newLamExp_MakeTuple(PI, expressions); @@ -485,7 +507,8 @@ static LamExp *lamConvertTuple(ParserInfo PI, AstExpressions *tuple, LamContext } /** - * @brief Converts an AST LookUp Expression (nameSpace dereference) to a lambda expression. + * @brief Converts an AST LookUp Expression (nameSpace dereference) to a lambda + * expression. * * @param lookUp The LookUp Expression to convert. * @param env The lambda context to use. @@ -495,7 +518,8 @@ static LamExp *lamConvertLookUp(AstLookUp *lookUp, LamContext *env) { LamContext *nsEnv = lookUpNameSpaceInLamContext(env, lookUp->nsId); LamExp *expression = convertExpression(lookUp->expression, nsEnv); int save = PROTECT(expression); - LamLookUp *llu = newLamLookUp(CPI(lookUp), lookUp->nsId, lookUp->nsSymbol, expression); + LamLookUp *llu = + newLamLookUp(CPI(lookUp), lookUp->nsId, lookUp->nsSymbol, expression); PROTECT(llu); LamExp *res = newLamExp_LookUp(CPI(lookUp), llu); UNPROTECT(save); @@ -503,43 +527,46 @@ static LamExp *lamConvertLookUp(AstLookUp *lookUp, LamContext *env) { } /** - * @brief Checks if a particular definition is a macro, and if so, adds it to the macro table in the environment. + * @brief Checks if a particular definition is a macro, and if so, adds it to + * the macro table in the environment. * * @param definition The AST definition to check. * @param env The lambda context to use. * @return void */ -static void checkMacro(AstDefinition *definition, LamContext *env) { - if (definition->type == AST_DEFINITION_TYPE_MACRO) { - setLamMacroSet(env->macros, getAstDefinition_Macro(definition)->name); +static void checkLazy(AstDefinition *definition, LamContext *env) { + if (definition->type == AST_DEFINITION_TYPE_LAZY) { + setSymbolSet(env->macros, getAstDefinition_Lazy(definition)->name); } } /** - * @brief Converts a list of AST function definitions to a list of letrec bindings. + * @brief Converts a list of AST function definitions to a list of letrec + * bindings. * * @param definitions The AST function definitions to convert. * @param env The lambda context to use. * @return The resulting list of letrec bindings. */ -static LamBindings *convertFuncDefs(AstDefinitions *definitions, LamContext *env) { +static LamBindings *convertFuncDefs(AstDefinitions *definitions, + LamContext *env) { ENTER(convertFuncDefs); if (definitions == NULL) { LEAVE(convertFuncDefs); return NULL; } - checkMacro(definitions->definition, env); + checkLazy(definitions->definition, env); LamBindings *next = convertFuncDefs(definitions->next, env); int save = PROTECT(next); - LamBindings *this = - prependDefinition(definitions->definition, env, next); + LamBindings *this = prependDefinition(definitions->definition, env, next); UNPROTECT(save); LEAVE(convertFuncDefs); return this; } /** - * @brief Converts a list of AST type symbols to a list of lambda type signature arguments. + * @brief Converts a list of AST type symbols to a list of lambda type signature + * arguments. * * @param symbols The AST type symbols to convert. * @return The resulting lambda type signature arguments. @@ -549,7 +576,8 @@ static LamTypeSigArgs *convertTypeSymbols(AstTypeSymbols *symbols) { return NULL; LamTypeSigArgs *next = convertTypeSymbols(symbols->next); int save = PROTECT(next); - LamTypeSigArgs *this = newLamTypeSigArgs(CPI(symbols), symbols->typeSymbol, next); + LamTypeSigArgs *this = + newLamTypeSigArgs(CPI(symbols), symbols->typeSymbol, next); UNPROTECT(save); return this; } @@ -578,7 +606,6 @@ static LamLookUpSymbol *convertAstLookUpSymbol(AstLookUpSymbol *ls) { return newLamLookUpSymbol(CPI(ls), ls->nsId, ls->nsSymbol, ls->symbol); } - /** * @brief Converts an AST LookUpOrSymbol to a lambda LookUpOrSymbol. * @@ -587,52 +614,57 @@ static LamLookUpSymbol *convertAstLookUpSymbol(AstLookUpSymbol *ls) { */ static LamLookUpOrSymbol *convertAstLookUpOrSymbol(AstLookUpOrSymbol *los) { switch (los->type) { - case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: - return newLamLookUpOrSymbol_Symbol(CPI(los), getAstLookUpOrSymbol_Symbol(los)); - case AST_LOOKUPORSYMBOL_TYPE_LOOKUP:{ - LamLookUpSymbol *ls = convertAstLookUpSymbol(getAstLookUpOrSymbol_LookUp(los)); - int save = PROTECT(ls); - LamLookUpOrSymbol *llos = newLamLookUpOrSymbol_LookUp(CPI(los), ls); - UNPROTECT(save); - return llos; - } - default: - cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); + case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: + return newLamLookUpOrSymbol_Symbol(CPI(los), + getAstLookUpOrSymbol_Symbol(los)); + case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: { + LamLookUpSymbol *ls = + convertAstLookUpSymbol(getAstLookUpOrSymbol_LookUp(los)); + int save = PROTECT(ls); + LamLookUpOrSymbol *llos = newLamLookUpOrSymbol_LookUp(CPI(los), ls); + UNPROTECT(save); + return llos; + } + default: + cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); } } /** - * @brief Checks to see if a symbol is an alias for a type constructor invocation. + * @brief Checks to see if a symbol is an alias for a type constructor + * invocation. * * @param los The AST LookUpOrSymbol to check. * @param env The lambda context to use. * @return The resulting lambda type constructor type, or NULL if not found. */ -static LamTypeConstructorType *expandSymbolAlias(AstLookUpOrSymbol *los, LamContext *env) { +static LamTypeConstructorType *expandSymbolAlias(AstLookUpOrSymbol *los, + LamContext *env) { switch (los->type) { - case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: { - LamTypeConstructorType *found = - lookUpConstructorTypeInLamContext(env, getAstLookUpOrSymbol_Symbol(los)); - if (found != NULL) { - return found; - } - return NULL; - } - case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: - return NULL; - default: - cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); + case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: { + LamTypeConstructorType *found = lookUpConstructorTypeInLamContext( + env, getAstLookUpOrSymbol_Symbol(los)); + if (found != NULL) { + return found; + } + return NULL; + } + case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: + return NULL; + default: + cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); } } /** * @brief checks to see if a type function is actually an alias for another. - * + * * @param function The AST type function to check. * @param env The lambda context to use. * @return The resulting lambda type constructor type, either original or alias. */ -static LamTypeConstructorType *expandFunctionAlias(AstTypeFunction *function, LamContext *env) { +static LamTypeConstructorType *expandFunctionAlias(AstTypeFunction *function, + LamContext *env) { if (function->typeList != NULL) { return NULL; } @@ -646,13 +678,15 @@ static LamTypeConstructorType *expandFunctionAlias(AstTypeFunction *function, La * @param env The lambda context to use. * @return The resulting lambda type function. */ -static LamTypeFunction *convertAstTypeFunction(AstTypeFunction *astTypeFunction, LamContext *env) { +static LamTypeFunction *convertAstTypeFunction(AstTypeFunction *astTypeFunction, + LamContext *env) { LamTypeConstructorArgs *lamTypeConstructorArgs = convertAstTypeList(astTypeFunction->typeList, env); int save = PROTECT(lamTypeConstructorArgs); LamLookUpOrSymbol *los = convertAstLookUpOrSymbol(astTypeFunction->symbol); PROTECT(los); - LamTypeFunction *this = newLamTypeFunction(CPI(los), los, lamTypeConstructorArgs); + LamTypeFunction *this = + newLamTypeFunction(CPI(los), los, lamTypeConstructorArgs); UNPROTECT(save); return this; } @@ -664,45 +698,49 @@ static LamTypeFunction *convertAstTypeFunction(AstTypeFunction *astTypeFunction, * @param env The lambda context to use. * @return The resulting lambda type constructor type. */ -static LamTypeConstructorType *convertAstTypeClause(AstTypeClause *astTypeClause, LamContext *env) { +static LamTypeConstructorType * +convertAstTypeClause(AstTypeClause *astTypeClause, LamContext *env) { switch (astTypeClause->type) { - case AST_TYPECLAUSE_TYPE_INTEGER: - return newLamTypeConstructorType_Integer(CPI(astTypeClause)); - case AST_TYPECLAUSE_TYPE_CHARACTER: - return newLamTypeConstructorType_Character(CPI(astTypeClause)); - case AST_TYPECLAUSE_TYPE_VAR: - return newLamTypeConstructorType_Var(CPI(astTypeClause), getAstTypeClause_Var(astTypeClause)); - case AST_TYPECLAUSE_TYPE_TYPEFUNCTION:{ - LamTypeConstructorType *alias = expandFunctionAlias(getAstTypeClause_TypeFunction(astTypeClause), env); - if (alias != NULL) { - return alias; - } - LamTypeFunction *lamTypeFunction = - convertAstTypeFunction(getAstTypeClause_TypeFunction(astTypeClause), env); - int save = PROTECT(lamTypeFunction); - LamTypeConstructorType *this = - newLamTypeConstructorType_Function(CPI(astTypeClause), lamTypeFunction); - UNPROTECT(save); - return this; - } - case AST_TYPECLAUSE_TYPE_TYPETUPLE: { - LamTypeConstructorArgs *lamTypeConstructorArgs = - convertAstTypeList(getAstTypeClause_TypeTuple(astTypeClause), env); - int save = PROTECT(lamTypeConstructorArgs); - LamTypeConstructorType *this = - newLamTypeConstructorType_Tuple(CPI(astTypeClause), lamTypeConstructorArgs); - UNPROTECT(save); - return this; + case AST_TYPECLAUSE_TYPE_INTEGER: + return newLamTypeConstructorType_Integer(CPI(astTypeClause)); + case AST_TYPECLAUSE_TYPE_CHARACTER: + return newLamTypeConstructorType_Character(CPI(astTypeClause)); + case AST_TYPECLAUSE_TYPE_VAR: + return newLamTypeConstructorType_Var( + CPI(astTypeClause), getAstTypeClause_Var(astTypeClause)); + case AST_TYPECLAUSE_TYPE_TYPEFUNCTION: { + LamTypeConstructorType *alias = expandFunctionAlias( + getAstTypeClause_TypeFunction(astTypeClause), env); + if (alias != NULL) { + return alias; } - default: - cant_happen - ("unrecognised astTypeClause type %d in convertAstTypeClause", - astTypeClause->type); + LamTypeFunction *lamTypeFunction = convertAstTypeFunction( + getAstTypeClause_TypeFunction(astTypeClause), env); + int save = PROTECT(lamTypeFunction); + LamTypeConstructorType *this = newLamTypeConstructorType_Function( + CPI(astTypeClause), lamTypeFunction); + UNPROTECT(save); + return this; + } + case AST_TYPECLAUSE_TYPE_TYPETUPLE: { + LamTypeConstructorArgs *lamTypeConstructorArgs = + convertAstTypeList(getAstTypeClause_TypeTuple(astTypeClause), env); + int save = PROTECT(lamTypeConstructorArgs); + LamTypeConstructorType *this = newLamTypeConstructorType_Tuple( + CPI(astTypeClause), lamTypeConstructorArgs); + UNPROTECT(save); + return this; + } + default: + cant_happen( + "unrecognised astTypeClause type %d in convertAstTypeClause", + astTypeClause->type); } } /** - * @brief Creates a lambda type function representing a function from one type to another. + * @brief Creates a lambda type function representing a function from one type + * to another. * * @param lhs The left-hand side type constructor. * @param rhs The right-hand side type constructor. @@ -710,11 +748,14 @@ static LamTypeConstructorType *convertAstTypeClause(AstTypeClause *astTypeClause */ static LamTypeFunction *makeArrow(LamTypeConstructorType *lhs, LamTypeConstructorType *rhs) { - LamTypeConstructorArgs *rhsArg = newLamTypeConstructorArgs(CPI(rhs), rhs, NULL); + LamTypeConstructorArgs *rhsArg = + newLamTypeConstructorArgs(CPI(rhs), rhs, NULL); int save = PROTECT(rhsArg); - LamTypeConstructorArgs *argss = newLamTypeConstructorArgs(CPI(lhs), lhs, rhsArg); + LamTypeConstructorArgs *argss = + newLamTypeConstructorArgs(CPI(lhs), lhs, rhsArg); PROTECT(argss); - LamLookUpOrSymbol *los = newLamLookUpOrSymbol_Symbol(CPI(lhs), arrowSymbol()); + LamLookUpOrSymbol *los = + newLamLookUpOrSymbol_Symbol(CPI(lhs), arrowSymbol()); PROTECT(los); LamTypeFunction *res = newLamTypeFunction(CPI(lhs), los, argss); UNPROTECT(save); @@ -730,8 +771,9 @@ static LamTypeFunction *makeArrow(LamTypeConstructorType *lhs, * @param env The lambda context to use. * @return The resulting lambda type constructor type. */ -static LamTypeConstructorType *convertAstType(AstType *astType, LamContext *env) { - if (astType->next) { // it's a function +static LamTypeConstructorType *convertAstType(AstType *astType, + LamContext *env) { + if (astType->next) { // it's a function LamTypeConstructorType *next = convertAstType(astType->next, env); int save = PROTECT(next); LamTypeConstructorType *this = @@ -749,63 +791,72 @@ static LamTypeConstructorType *convertAstType(AstType *astType, LamContext *env) } /** - * @brief Converts an AST Type List to a list of lambda type constructor arguments. + * @brief Converts an AST Type List to a list of lambda type constructor + * arguments. * * @param typeList The AST Type List to convert. * @param env The lambda context to use. * @return The resulting list of lambda type constructor arguments. */ -static LamTypeConstructorArgs *convertAstTypeList(AstTypeList *typeList, LamContext *env) { +static LamTypeConstructorArgs *convertAstTypeList(AstTypeList *typeList, + LamContext *env) { if (typeList == NULL) return NULL; LamTypeConstructorArgs *next = convertAstTypeList(typeList->next, env); int save = PROTECT(next); LamTypeConstructorType *arg = convertAstType(typeList->type, env); PROTECT(arg); - LamTypeConstructorArgs *this = newLamTypeConstructorArgs(CPI(arg), arg, next); + LamTypeConstructorArgs *this = + newLamTypeConstructorArgs(CPI(arg), arg, next); UNPROTECT(save); return this; } /** - * @brief Converts an AST Type Map to a list of lambda type constructor arguments. + * @brief Converts an AST Type Map to a list of lambda type constructor + * arguments. * * @param typeMap The AST Type Map to convert. * @param env The lambda context to use. * @return The resulting list of lambda type constructor arguments. */ -static LamTypeConstructorArgs *convertAstTypeMap(AstTypeMap *typeMap, LamContext *env) { +static LamTypeConstructorArgs *convertAstTypeMap(AstTypeMap *typeMap, + LamContext *env) { if (typeMap == NULL) return NULL; LamTypeConstructorArgs *next = convertAstTypeMap(typeMap->next, env); int save = PROTECT(next); LamTypeConstructorType *arg = convertAstType(typeMap->type, env); PROTECT(arg); - LamTypeConstructorArgs *this = newLamTypeConstructorArgs(CPI(arg), arg, next); + LamTypeConstructorArgs *this = + newLamTypeConstructorArgs(CPI(arg), arg, next); UNPROTECT(save); return this; } /** - * @brief Converts AST Type Constructor Arguments (list or map) to a list of lambda type constructor arguments. + * @brief Converts AST Type Constructor Arguments (list or map) to a list of + * lambda type constructor arguments. * * @param args The AST Type Constructor Arguments to convert. * @param env The lambda context to use. * @return The resulting list of lambda type constructor arguments. */ -static LamTypeConstructorArgs *convertAstTypeConstructorArgs(AstTypeConstructorArgs *args, LamContext *env) { +static LamTypeConstructorArgs * +convertAstTypeConstructorArgs(AstTypeConstructorArgs *args, LamContext *env) { if (args == NULL) { return NULL; } switch (args->type) { - case AST_TYPECONSTRUCTORARGS_TYPE_LIST:{ - return convertAstTypeList(getAstTypeConstructorArgs_List(args), env); - } - case AST_TYPECONSTRUCTORARGS_TYPE_MAP:{ - return convertAstTypeMap(getAstTypeConstructorArgs_Map(args), env); - } - default: - cant_happen("unrecognized %s", astTypeConstructorArgsTypeName(args->type)); + case AST_TYPECONSTRUCTORARGS_TYPE_LIST: { + return convertAstTypeList(getAstTypeConstructorArgs_List(args), env); + } + case AST_TYPECONSTRUCTORARGS_TYPE_MAP: { + return convertAstTypeMap(getAstTypeConstructorArgs_Map(args), env); + } + default: + cant_happen("unrecognized %s", + astTypeConstructorArgsTypeName(args->type)); } } @@ -819,7 +870,8 @@ static LamTypeConstructorArgs *convertAstTypeConstructorArgs(AstTypeConstructorA * @return The resulting list of lambda type tags. */ static LamTypeTags *astTypeConstructorArgMapToTags(AstTypeMap *map) { - if (map == NULL) return NULL; + if (map == NULL) + return NULL; LamTypeTags *next = astTypeConstructorArgMapToTags(map->next); int save = PROTECT(next); LamTypeTags *this = newLamTypeTags(CPI(map), map->key, next); @@ -828,44 +880,44 @@ static LamTypeTags *astTypeConstructorArgMapToTags(AstTypeMap *map) { } /** - * @brief converts the AST Type Constructor Arguments to a list of lambda type tags, IFF - * the arguments are a map. + * @brief converts the AST Type Constructor Arguments to a list of lambda type + * tags, IFF the arguments are a map. * * @param args The AST Type Constructor Arguments to convert. - * @return The resulting list of lambda type tags, or NULL if the arguments are not a map. + * @return The resulting list of lambda type tags, or NULL if the arguments are + * not a map. */ static LamTypeTags *makeLamTypeTags(AstTypeConstructorArgs *args) { if (args == NULL) { return NULL; } switch (args->type) { - case AST_TYPECONSTRUCTORARGS_TYPE_LIST: - return NULL; - case AST_TYPECONSTRUCTORARGS_TYPE_MAP: - return astTypeConstructorArgMapToTags(getAstTypeConstructorArgs_Map(args)); - default: - cant_happen("unrecognized %s", astTypeConstructorArgsTypeName(args->type)); + case AST_TYPECONSTRUCTORARGS_TYPE_LIST: + return NULL; + case AST_TYPECONSTRUCTORARGS_TYPE_MAP: + return astTypeConstructorArgMapToTags( + getAstTypeConstructorArgs_Map(args)); + default: + cant_happen("unrecognized %s", + astTypeConstructorArgsTypeName(args->type)); } } /** - * @brief Collects as much type information as possible about the type constructor and stores it in the context. + * @brief Collects as much type information as possible about the type + * constructor and stores it in the context. */ -static void collectTypeInfo(HashSymbol *symbol, - AstTypeConstructorArgs *args, - LamTypeConstructor *type, - bool needsVec, - int enumCount, - int index, - int arity, +static void collectTypeInfo(HashSymbol *symbol, AstTypeConstructorArgs *args, + LamTypeConstructor *type, bool needsVec, + int enumCount, int index, int arity, LamContext *env) { ENTER(collectTypeInfo); int nameSpace = lookUpCurrentNameSpaceInLamContext(env); LamTypeTags *tags = makeLamTypeTags(args); int save = PROTECT(tags); LamTypeConstructorInfo *info = - newLamTypeConstructorInfo(CPI(type), symbol, nameSpace, type, tags, needsVec, - arity, enumCount, index); + newLamTypeConstructorInfo(CPI(type), symbol, nameSpace, type, tags, + needsVec, arity, enumCount, index); PROTECT(info); addConstructorInfoToLamContext(env, symbol, info); UNPROTECT(save); @@ -873,27 +925,31 @@ static void collectTypeInfo(HashSymbol *symbol, } /** - * @brief counts the number of items in the AST Type Constructor Arguments (list or map). + * @brief counts the number of items in the AST Type Constructor Arguments (list + * or map). * * @param args The AST Type Constructor Arguments to count. * @return The number of items in the arguments. */ static Index countAstTypeConstructorArgs(AstTypeConstructorArgs *args) { - if (args == NULL) return 0; + if (args == NULL) + return 0; switch (args->type) { - case AST_TYPECONSTRUCTORARGS_TYPE_LIST:{ - return countAstTypeList(getAstTypeConstructorArgs_List(args)); - } - case AST_TYPECONSTRUCTORARGS_TYPE_MAP:{ - return countAstTypeMap(getAstTypeConstructorArgs_Map(args)); - } - default: - cant_happen("unrecognized %s", astTypeConstructorArgsTypeName(args->type)); + case AST_TYPECONSTRUCTORARGS_TYPE_LIST: { + return countAstTypeList(getAstTypeConstructorArgs_List(args)); + } + case AST_TYPECONSTRUCTORARGS_TYPE_MAP: { + return countAstTypeMap(getAstTypeConstructorArgs_Map(args)); + } + default: + cant_happen("unrecognized %s", + astTypeConstructorArgsTypeName(args->type)); } } /** - * @brief Converts an AST Type Constructor to a lambda type constructor and collects its type information. + * @brief Converts an AST Type Constructor to a lambda type constructor and + * collects its type information. * * @param typeConstructor The AST Type Constructor to convert. * @param type The type signature of the constructor type. @@ -902,12 +958,10 @@ static Index countAstTypeConstructorArgs(AstTypeConstructorArgs *args) { * @param needsVec Whether the constructor needs to create a vector. * @return The resulting lambda type constructor. */ -static LamTypeConstructor *convertTypeConstructor(AstTypeConstructor *typeConstructor, - LamTypeSig *type, - int enumCount, - int index, - bool needsVec, - LamContext *env) { +static LamTypeConstructor * +convertTypeConstructor(AstTypeConstructor *typeConstructor, LamTypeSig *type, + int enumCount, int index, bool needsVec, + LamContext *env) { int nArgs = countAstTypeConstructorArgs(typeConstructor->args); LamTypeConstructorArgs *args = convertAstTypeConstructorArgs(typeConstructor->args, env); @@ -915,8 +969,8 @@ static LamTypeConstructor *convertTypeConstructor(AstTypeConstructor *typeConstr LamTypeConstructor *lamTypeConstructor = newLamTypeConstructor(CPI(type), typeConstructor->symbol, type, args); PROTECT(lamTypeConstructor); - collectTypeInfo(typeConstructor->symbol, typeConstructor->args, lamTypeConstructor, needsVec, - enumCount, index, nArgs, env); + collectTypeInfo(typeConstructor->symbol, typeConstructor->args, + lamTypeConstructor, needsVec, enumCount, index, nArgs, env); UNPROTECT(save); return lamTypeConstructor; } @@ -938,17 +992,12 @@ static LamTypeDef *convertTypeDef(AstTypeDef *typeDef, LamContext *env) { LamTypeConstructorList *lamTypeConstructorList = NULL; int save2 = PROTECT(type); while (typeBody != NULL) { - LamTypeConstructor *lamTypeConstructor = - convertTypeConstructor(typeBody->typeConstructor, - type, - enumCount, - index, - needsVec, - env); + LamTypeConstructor *lamTypeConstructor = convertTypeConstructor( + typeBody->typeConstructor, type, enumCount, index, needsVec, env); int save3 = PROTECT(lamTypeConstructor); - lamTypeConstructorList = - newLamTypeConstructorList(CPI(lamTypeConstructor), lamTypeConstructor, - lamTypeConstructorList); + lamTypeConstructorList = newLamTypeConstructorList( + CPI(lamTypeConstructor), lamTypeConstructor, + lamTypeConstructorList); REPLACE_PROTECT(save2, lamTypeConstructorList); UNPROTECT(save3); typeBody = typeBody->next; @@ -974,7 +1023,8 @@ static void collectAlias(AstAlias *alias, LamContext *env) { } /** - * @brief recurses over a list of definitions, collecting any aliases in the context. + * @brief recurses over a list of definitions, collecting any aliases in the + * context. * * @param definitions The list of AST definitions to process. * @param env The lambda context to populate. @@ -985,17 +1035,18 @@ static void collectAliases(AstDefinitions *definitions, LamContext *env) { return; } switch (definitions->definition->type) { - case AST_DEFINITION_TYPE_DEFINE: - case AST_DEFINITION_TYPE_BLANK: - case AST_DEFINITION_TYPE_TYPEDEF: - case AST_DEFINITION_TYPE_MACRO: - case AST_DEFINITION_TYPE_MULTI: - break; - case AST_DEFINITION_TYPE_ALIAS: - collectAlias(getAstDefinition_Alias(definitions->definition), env); - break; - default: - cant_happen("unrecognised %s", astDefinitionTypeName(definitions->definition->type)); + case AST_DEFINITION_TYPE_DEFINE: + case AST_DEFINITION_TYPE_BLANK: + case AST_DEFINITION_TYPE_TYPEDEF: + case AST_DEFINITION_TYPE_LAZY: + case AST_DEFINITION_TYPE_MULTI: + break; + case AST_DEFINITION_TYPE_ALIAS: + collectAlias(getAstDefinition_Alias(definitions->definition), env); + break; + default: + cant_happen("unrecognised %s", + astDefinitionTypeName(definitions->definition->type)); } collectAliases(definitions->next, env); } @@ -1007,13 +1058,15 @@ static void collectAliases(AstDefinitions *definitions, LamContext *env) { * @param args The list of existing macro arguments. * @return void */ -static void checkDuplicateMacroArg(HashSymbol *arg, LamVarList *args) { - if (args == NULL) return; - if (arg == args->var) { - conversionError(CPI(args), "duplicate argument \"%s\" in macro definition", arg->name); +static void checkDuplicateLazyArg(HashSymbol *arg, SymbolList *args) { + if (args == NULL) + return; + if (arg == args->symbol) { + can_happen(CPI(args), "duplicate argument \"%s\" in macro definition", + arg->name); return; } - checkDuplicateMacroArg(arg, args->next); + checkDuplicateLazyArg(arg, args->next); } /** @@ -1025,13 +1078,14 @@ static void checkDuplicateMacroArg(HashSymbol *arg, LamVarList *args) { * @param argList The AST argument list to collect from. * @return A linked list of lambda variable arguments. */ -static LamVarList *collectMacroArgs(AstFargList *argList) { - if (argList == NULL) return NULL; - LamVarList *next = collectMacroArgs(argList->next); +static SymbolList *collectLazyArgs(AstFargList *argList) { + if (argList == NULL) + return NULL; + SymbolList *next = collectLazyArgs(argList->next); int save = PROTECT(next); HashSymbol *arg = getAstFarg_Symbol(argList->arg); - checkDuplicateMacroArg(arg, next); - LamVarList *this = newLamVarList(CPI(argList), arg, next); + checkDuplicateLazyArg(arg, next); + SymbolList *this = newSymbolList(CPI(argList), arg, next); UNPROTECT(save); return this; } @@ -1039,52 +1093,53 @@ static LamVarList *collectMacroArgs(AstFargList *argList) { /** * @brief Populates a lambda macro arguments table from a list of arguments. * - * This function iterates over the list of lambda variable arguments and adds each one - * to the macro arguments table with a NULL value. - * + * This function iterates over the list of lambda variable arguments and adds + * each one to the macro arguments table with a NULL value. + * * @param symbols The macro arguments table to populate. * @param args The list of lambda variable arguments. * @return void */ -static void populateArgsTable(LamMacroArgsSet *symbols, LamVarList *args) { - if (args == NULL) return; - setLamMacroArgsSet(symbols, args->var); +static void populateArgsTable(SymbolSet *symbols, SymbolList *args) { + if (args == NULL) + return; + setSymbolSet(symbols, args->symbol); populateArgsTable(symbols, args->next); } /** - * @brief Converts an AST Macro Definition to a lambda expression. + * @brief Converts an AST Lazy Definition to a lambda expression. * - * This function converts the macro definition into a lambda expression. - * Macros evaluate their arguments on-demand, so the generated macro + * This function converts the lazy definition into a lambda expression. + * Lazys evaluate their arguments on-demand, so the generated lazy lambda * must wrap each of its arguments in a promise. * - * @param astMacro The AST Macro Definition to convert. + * @param astLazy The AST Lazy Definition to convert. * @param env The lambda context to use. * @return The resulting lambda expression for the macro. */ -static LamExp *convertAstMacro(AstDefMacro *astMacro, LamContext *env) { - ENTER(convertAstMacro); +static LamExp *convertAstLazy(AstDefLazy *astLazy, LamContext *env) { + ENTER(convertAstLazy); // get the list of argument symbols - LamVarList *args = collectMacroArgs(astMacro->definition->altArgs->argList); + SymbolList *args = collectLazyArgs(astLazy->definition->altArgs->argList); int save = PROTECT(args); // do a standard conversion of the macro body - LamExp *body = convertNest(astMacro->definition->nest, env); + LamExp *body = convertNest(astLazy->definition->nest, env); PROTECT(body); // create a random-access set of the macro argument symbols - LamMacroArgsSet *symbolTable = newLamMacroArgsSet(); + SymbolSet *symbolTable = newSymbolSet(); PROTECT(symbolTable); populateArgsTable(symbolTable, args); // force all the argument thunks in the body of the macro - body = lamPerformMacroSubstitutions(body, symbolTable); + body = lamPerformLazySubstitutions(body, symbolTable); PROTECT(body); // prepare the resulting lambda expression - LamExp *res = makeLamExp_Lam(CPI(astMacro), args, body); + LamExp *res = makeLamExp_Lam(CPI(astLazy), args, body); PROTECT(res); - getLamExp_Lam(res)->isMacro = true; + getLamExp_Lam(res)->isLazy = true; // remember it's a macro - setLamMacroSet(env->macros, astMacro->name); - LEAVE(convertAstMacro); + setSymbolSet(env->macros, astLazy->name); + LEAVE(convertAstLazy); UNPROTECT(save); return res; } @@ -1099,72 +1154,68 @@ static LamExp *convertAstMacro(AstDefMacro *astMacro, LamContext *env) { * @param env The lambda context to use. * @return A linked list of lambda type definitions. */ -static LamTypeDefList *collectTypeDefs(AstDefinitions *definitions, LamContext *env) { +static LamTypeDefList *collectTypeDefs(AstDefinitions *definitions, + LamContext *env) { if (definitions == NULL) { return NULL; } switch (definitions->definition->type) { - case AST_DEFINITION_TYPE_DEFINE: - case AST_DEFINITION_TYPE_ALIAS: - case AST_DEFINITION_TYPE_BLANK: - case AST_DEFINITION_TYPE_MACRO: - case AST_DEFINITION_TYPE_MULTI: - return collectTypeDefs(definitions->next, env); - case AST_DEFINITION_TYPE_TYPEDEF:{ - LamTypeDef *lamTypeDef = convertTypeDef(getAstDefinition_TypeDef(definitions->definition), env); - int save = PROTECT(lamTypeDef); - LamTypeDefList *rest = collectTypeDefs(definitions->next, env); - PROTECT(rest); - LamTypeDefList *res = newLamTypeDefList(CPI(lamTypeDef), lamTypeDef, rest); - UNPROTECT(save); - return res; - } - default: - cant_happen("unrecognised %s", astDefinitionTypeName(definitions->definition->type)); - } -} - -/** - * @brief Convert and prepend a macro to the list of letRec bindings. - * @param macro The AST macro definition to convert. + case AST_DEFINITION_TYPE_DEFINE: + case AST_DEFINITION_TYPE_ALIAS: + case AST_DEFINITION_TYPE_BLANK: + case AST_DEFINITION_TYPE_LAZY: + case AST_DEFINITION_TYPE_MULTI: + return collectTypeDefs(definitions->next, env); + case AST_DEFINITION_TYPE_TYPEDEF: { + LamTypeDef *lamTypeDef = convertTypeDef( + getAstDefinition_TypeDef(definitions->definition), env); + int save = PROTECT(lamTypeDef); + LamTypeDefList *rest = collectTypeDefs(definitions->next, env); + PROTECT(rest); + LamTypeDefList *res = + newLamTypeDefList(CPI(lamTypeDef), lamTypeDef, rest); + UNPROTECT(save); + return res; + } + default: + cant_happen("unrecognised %s", + astDefinitionTypeName(definitions->definition->type)); + } +} + +/** + * @brief Convert and prepend a lazy definition to the list of letRec bindings. + * @param lazy The AST lazy definition to convert. * @param env The lambda context to use. * @param next The letRec list to prepend to. - * @return The new letRec bindings with the macro prepended. + * @return The new letRec bindings with the lazy definition prepended. */ -static LamBindings *prependMacro(AstDefMacro * macro, LamContext * env, - LamBindings * next) { - ENTER(prependMacro); - LamExp *exp = convertAstMacro(macro, env); +static LamBindings *prependLazy(AstDefLazy *lazy, LamContext *env, + LamBindings *next) { + ENTER(prependLazy); + LamExp *exp = convertAstLazy(lazy, env); int save = PROTECT(exp); - LamBindings *this = - newLamBindings(CPI(macro), macro->name, exp, next); + LamBindings *this = newLamBindings(CPI(lazy), lazy->name, exp, next); UNPROTECT(save); - LEAVE(prependMacro); + LEAVE(prependLazy); return this; } LamExp *makeUnpackTuple(ParserInfo PI, LamExp *temp, int index, int size) { - LamTupleIndex *tupleIndex = - newLamTupleIndex(PI, index, size, temp); - int save = PROTECT(tupleIndex); - LamExp *exp = newLamExp_TupleIndex(PI, tupleIndex); - UNPROTECT(save); - return exp; + return makeLamExp_TupleIndex(PI, index, size, temp); } -static LamBindings *prependMultiSymbols(AstSymbolList *symbols, - int index, - int size, - LamExp * temp, - LamBindings * next) { +static LamBindings *prependMultiSymbols(AstSymbolList *symbols, int index, + int size, LamExp *temp, + LamBindings *next) { if (symbols == NULL) { return next; } - LamBindings *rest = prependMultiSymbols(symbols->next, - index + 1, - size, - temp, - next); + LamBindings *rest = + prependMultiSymbols(symbols->next, index + 1, size, temp, next); + if (symbols->symbol == TOK_WILDCARD()) { + return rest; + } int save = PROTECT(rest); LamExp *rhs = makeUnpackTuple(CPI(symbols), temp, index, size); PROTECT(rhs); @@ -1174,19 +1225,16 @@ static LamBindings *prependMultiSymbols(AstSymbolList *symbols, return this; } -static LamBindings *prependMulti(AstMultiDefine * multi, LamContext * env, - LamBindings * next) { +static LamBindings *prependMulti(AstMultiDefine *multi, LamContext *env, + LamBindings *next) { ENTER(prependMulti); LamExp *exp = convertExpression(multi->expression, env); int save = PROTECT(exp); HashSymbol *temp = genSymDollar("multi"); LamExp *tempExp = newLamExp_Var(CPI(multi), temp); PROTECT(tempExp); - LamBindings *parts = prependMultiSymbols(multi->symbols, - 0, - countAstSymbolList(multi->symbols), - tempExp, - next); + LamBindings *parts = prependMultiSymbols( + multi->symbols, 0, countAstSymbolList(multi->symbols), tempExp, next); PROTECT(parts); LamBindings *this = newLamBindings(CPI(multi), temp, exp, parts); UNPROTECT(save); @@ -1206,49 +1254,50 @@ static LamBindings *prependMulti(AstMultiDefine * multi, LamContext * env, * @return The new letRec bindings with the definition prepended. */ static LamBindings *prependDefinition(AstDefinition *definition, - LamContext *env, - LamBindings *next) { + LamContext *env, LamBindings *next) { ENTER(prependDefinition); LamBindings *result = NULL; switch (definition->type) { - case AST_DEFINITION_TYPE_DEFINE: - result = prependDefine(getAstDefinition_Define(definition), env, next); - break; - case AST_DEFINITION_TYPE_MACRO: - result = prependMacro(getAstDefinition_Macro(definition), env, next); - break; - case AST_DEFINITION_TYPE_MULTI: - result = prependMulti(getAstDefinition_Multi(definition), env, next); - break; - case AST_DEFINITION_TYPE_ALIAS: - case AST_DEFINITION_TYPE_TYPEDEF: - case AST_DEFINITION_TYPE_BLANK: - result = next; - break; - default: - cant_happen("unrecognised %s", astDefinitionTypeName(definition->type)); + case AST_DEFINITION_TYPE_DEFINE: + result = prependDefine(getAstDefinition_Define(definition), env, next); + break; + case AST_DEFINITION_TYPE_LAZY: + result = prependLazy(getAstDefinition_Lazy(definition), env, next); + break; + case AST_DEFINITION_TYPE_MULTI: + result = prependMulti(getAstDefinition_Multi(definition), env, next); + break; + case AST_DEFINITION_TYPE_ALIAS: + case AST_DEFINITION_TYPE_TYPEDEF: + case AST_DEFINITION_TYPE_BLANK: + result = next; + break; + default: + cant_happen("unrecognised %s", astDefinitionTypeName(definition->type)); } LEAVE(prependDefinition); return result; } /** - * @brief Checks if a type body has any fields (i.e., type constructor arguments). + * @brief Checks if a type body has any fields (i.e., type constructor + * arguments). * * This function iterates over the type body and checks if any type constructor - * has arguments defined. This is done to determine if the type should be constructed - * as a simple scalar or if it needs to be a vector. - * + * has arguments defined. This is done to determine if the type should be + * constructed as a simple scalar or if it needs to be a vector. + * * For example in * ``` * typedef colour { red | green | blue } * ``` - * because none of the constructors have arguments, they can all be represented as simple scalars. - * Bit in the case of + * because none of the constructors have arguments, they can all be represented + * as simple scalars. Bit in the case of * ``` * typedef list(#t) { null | cons(#t, list(#t))} * ``` - * because `cons` has fields, both `null` and `cons` need to be represented as vectors. + * because `cons` has fields, both `null` and `cons` need to be represented as + * vectors. * * @param typeBody The AST Type Body to check. * @return true if there are fields, false otherwise. @@ -1273,44 +1322,47 @@ static bool typeHasFields(AstTypeBody *typeBody) { * @param next The current letrec bindings. * @return The new letRec bindings with the definition prepended. */ -static LamBindings *prependDefine(AstDefine * define, LamContext * env, - LamBindings * next) { +static LamBindings *prependDefine(AstDefine *define, LamContext *env, + LamBindings *next) { ENTER(prependDefine); - bool doMermaid = (tpmc_mermaid_function != NULL - && strcmp(tpmc_mermaid_function, - define->symbol->name) == 0); + bool doMermaid = (tpmc_mermaid_function != NULL && + strcmp(tpmc_mermaid_function, define->symbol->name) == 0); if (doMermaid) tpmc_mermaid_flag = 1; LamExp *exp = convertExpression(define->expression, env); - if (lambda_conversion_function != NULL && strcmp(lambda_conversion_function, define->symbol->name) == 0) { + if (lambda_conversion_function != NULL && + strcmp(lambda_conversion_function, define->symbol->name) == 0) { ppLamExp(exp); eprintf("\n"); } if (doMermaid) tpmc_mermaid_flag = 0; int save = PROTECT(exp); - LamBindings *this = - newLamBindings(CPI(define), define->symbol, exp, next); + LamBindings *this = newLamBindings(CPI(define), define->symbol, exp, next); UNPROTECT(save); LEAVE(prependDefine); return this; } -#define CHECK_ONE_ARG(name, args) do { \ - int count = countLamArgs(args); \ - if (count != 1) \ - conversionError(CPI(args), "expected 1 arg in " #name ", got %d", count); \ -} while(0) +#define CHECK_ONE_ARG(name, args) \ + do { \ + int count = countLamArgs(args); \ + if (count != 1) \ + can_happen(CPI(args), "expected 1 arg in " #name ", got %d", \ + count); \ + } while (0) -#define CHECK_TWO_ARGS(name, args) do { \ - int count = countLamArgs(args); \ - if (count != 2) \ - conversionError(CPI(args), "expected 2 args in " #name ", got %d", count); \ -} while(0) +#define CHECK_TWO_ARGS(name, args) \ + do { \ + int count = countLamArgs(args); \ + if (count != 2) \ + can_happen(CPI(args), "expected 2 args in " #name ", got %d", \ + count); \ + } while (0) /** * @brief Creates a call/cc expression. - * + * * @param args The arguments to the call/cc expression. * @return the lambda expression. */ @@ -1321,18 +1373,14 @@ static LamExp *makeCallCC(LamArgs *args) { /** * @brief Creates a binary operation expression. - * + * * @param opCode The operation code for the binary operation. * @param args The arguments to the binary operation. * @return The resulting lambda expression for the binary operation. */ static LamExp *makeBinOp(LamPrimOp opCode, LamArgs *args) { CHECK_TWO_ARGS(makeBinOp, args); - LamPrimApp *app = newLamPrimApp(CPI(args), opCode, args->exp, args->next->exp); - int save = PROTECT(app); - LamExp *exp = newLamExp_Prim(CPI(app), app); - UNPROTECT(save); - return exp; + return makeLamExp_Prim(CPI(args), opCode, args->exp, args->next->exp); } /** @@ -1342,11 +1390,7 @@ static LamExp *makeBinOp(LamPrimOp opCode, LamArgs *args) { */ static LamExp *makeLamAmb(LamArgs *args) { CHECK_TWO_ARGS(makeLamAmb, args); - LamAmb *lamAmb = newLamAmb(CPI(args), args->exp, args->next->exp); - int save = PROTECT(lamAmb); - LamExp *res = newLamExp_Amb(CPI(lamAmb), lamAmb); - UNPROTECT(save); - return res; + return makeLamExp_Amb(CPI(args), args->exp, args->next->exp); } /** @@ -1373,27 +1417,28 @@ static LamExp *makeUnaryNeg(LamArgs *args) { * @param env The environment to search in. * @return True if the symbol is a macro, false otherwise. */ -static bool isMacro(HashSymbol *symbol, LamContext *env) { +static bool isLazy(HashSymbol *symbol, LamContext *env) { if (env == NULL) { return false; } - if (getLamMacroSet(env->macros, symbol)) { + if (getSymbolSet(env->macros, symbol)) { return true; } - return isMacro(symbol, env->parent); + return isLazy(symbol, env->parent); } /** * @brief Wraps a macro argument in a thunk. - * - * @description A thunk is a lambda with no arguments that returns the argument when called. - * This allows macros to evaluate their arguments on-demand. The equivalent invocation of the thunk - * is generated by `performVarSubstitution` in `macro_substitution.c`. - * + * + * @description A thunk is a lambda with no arguments that returns the argument + * when called. This allows macros to evaluate their arguments on-demand. The + * equivalent invocation of the thunk is generated by `performVarSubstitution` + * in `macro_substitution.c`. + * * @param arg The argument to wrap. * @return The resulting thunked argument. */ -static LamExp *thunkMacroArg(LamExp *arg) { +static LamExp *thunkLazyArg(LamExp *arg) { LamExp *res = makeLamExp_Lam(CPI(arg), NULL, arg); return res; } @@ -1403,13 +1448,13 @@ static LamExp *thunkMacroArg(LamExp *arg) { * @param args The arguments to wrap. * @return The resulting wrapped arguments. */ -static LamArgs *thunkMacroArgs(LamArgs *args) { +static LamArgs *thunkLazyArgs(LamArgs *args) { if (args == NULL) { return NULL; } - LamArgs *next = thunkMacroArgs(args->next); + LamArgs *next = thunkLazyArgs(args->next); int save = PROTECT(next); - LamExp *arg = thunkMacroArg(args->exp); + LamExp *arg = thunkLazyArg(args->exp); PROTECT(arg); LamArgs *this = newLamArgs(CPI(arg), arg, next); UNPROTECT(save); @@ -1417,15 +1462,15 @@ static LamArgs *thunkMacroArgs(LamArgs *args) { } /** - * @brief Converts a macro application where the callee is an arbitrary expression - * (e.g., a nameSpaced lookUp), wrapping the arguments in thunks. + * @brief Converts a macro application where the callee is an arbitrary + * expression (e.g., a nameSpaced lookUp), wrapping the arguments in thunks. * @param PI The parser information. * @param callee The callee expression (can be a LookUp or Var). * @param args The arguments to the macro. * @return The resulting lambda expression. */ -static LamExp *thunkMacroExp(ParserInfo PI, LamExp *callee, LamArgs *args) { - args = thunkMacroArgs(args); +static LamExp *thunkLazyExp(ParserInfo PI, LamExp *callee, LamArgs *args) { + args = thunkLazyArgs(args); int save = PROTECT(args); LamExp *res = makeLamExp_Apply(PI, callee, args); UNPROTECT(save); @@ -1433,30 +1478,34 @@ static LamExp *thunkMacroExp(ParserInfo PI, LamExp *callee, LamArgs *args) { } /** - * @brief Converts a macro application into a lambda expression, wrapping the arguments in thunks. + * @brief Converts a macro application into a lambda expression, wrapping the + * arguments in thunks. * @param PI The parser information. * @param symbol The macro name. * @param args The arguments to the macro. * @return The resulting lambda expression. */ -static LamExp *thunkMacroSymbol(ParserInfo PI, HashSymbol *symbol, LamArgs *args) { +static LamExp *thunkLazySymbol(ParserInfo PI, HashSymbol *symbol, + LamArgs *args) { LamExp *exp = newLamExp_Var(PI, symbol); int save = PROTECT(exp); - LamExp *res = thunkMacroExp(PI, exp, args); + LamExp *res = thunkLazyExp(PI, exp, args); UNPROTECT(save); return res; } /** - * @brief Creates a lambda primitive application based on the symbol and arguments. + * @brief Creates a lambda primitive application based on the symbol and + * arguments. * @param PI The parser information. * @param symbol The macro or operator name. * @param args The arguments to the macro. * @return The resulting lambda expression. */ -static LamExp *makePrimApp(ParserInfo PI, HashSymbol *symbol, LamArgs *args, LamContext *env) { - if (isMacro(symbol, env)) { - return thunkMacroSymbol(PI, symbol, args); +static LamExp *makePrimApp(ParserInfo PI, HashSymbol *symbol, LamArgs *args, + LamContext *env) { + if (isLazy(symbol, env)) { + return thunkLazySymbol(PI, symbol, args); } if (symbol == negSymbol()) return makeUnaryNeg(args); @@ -1494,7 +1543,8 @@ static LamExp *makePrimApp(ParserInfo PI, HashSymbol *symbol, LamArgs *args, Lam } /** - * @brief Provisionally creates a constructor application if the symbol is a constructor in the current env. + * @brief Provisionally creates a constructor application if the symbol is a + * constructor in the current env. * @param symbol The symbol. * @param env The environment to look in. * @return The resulting lambda expression, or NULL. @@ -1523,11 +1573,12 @@ static LamExp *makeApplication(LamExp *fun, LamArgs *args) { * @param list The list of bound variables. * @return The resulting list of lambda arguments. */ -static LamArgs *varListToList(LamVarList *list) { - if (list == NULL) return NULL; +static LamArgs *varListToList(SymbolList *list) { + if (list == NULL) + return NULL; LamArgs *next = varListToList(list->next); int save = PROTECT(next); - LamExp *var = newLamExp_Var(CPI(list), list->var); + LamExp *var = newLamExp_Var(CPI(list), list->symbol); PROTECT(var); LamArgs *this = newLamArgs(CPI(var), var, next); UNPROTECT(save); @@ -1540,21 +1591,21 @@ static LamArgs *varListToList(LamVarList *list) { * @param nArgs The number of arguments. * @return The resulting list of symbolic variables. */ -static LamVarList *genSymVarList(ParserInfo I, int nArgs) { +static SymbolList *genSymVarList(ParserInfo I, int nArgs) { if (nArgs == 0) { return NULL; } - LamVarList *rest = genSymVarList(I, nArgs - 1); + SymbolList *rest = genSymVarList(I, nArgs - 1); int save = PROTECT(rest); HashSymbol *s = genSym("$x"); - LamVarList *this = newLamVarList(I, s, rest); + SymbolList *this = newSymbolList(I, s, rest); UNPROTECT(save); return this; } /** * @brief Finds the underlying arity of a lambda expression. - * + * * This function checks if the expression is a constructor or a lookUp, * and returns the arity of the constructor or recursively finds the arity * of the underlying expression in case of a lookUp. @@ -1564,12 +1615,12 @@ static LamVarList *genSymVarList(ParserInfo I, int nArgs) { */ static int findUnderlyingArity(LamExp *exp) { switch (exp->type) { - case LAMEXP_TYPE_CONSTRUCTOR: - return getLamExp_Constructor(exp)->arity; - case LAMEXP_TYPE_LOOKUP: - return findUnderlyingArity(getLamExp_LookUp(exp)->exp); - default: - cant_happen("expected lookUp or constructor"); + case LAMEXP_TYPE_CONSTRUCTOR: + return getLamExp_Constructor(exp)->arity; + case LAMEXP_TYPE_LOOKUP: + return findUnderlyingArity(getLamExp_LookUp(exp)->exp); + default: + cant_happen("expected lookUp or constructor"); } } @@ -1580,16 +1631,16 @@ static int findUnderlyingArity(LamExp *exp) { */ static int findUnderlyingType(LamExp *exp) { switch (exp->type) { - case LAMEXP_TYPE_LOOKUP: - return findUnderlyingType(getLamExp_LookUp(exp)->exp); - default: - return exp->type; + case LAMEXP_TYPE_LOOKUP: + return findUnderlyingType(getLamExp_LookUp(exp)->exp); + default: + return exp->type; } } /** * @brief Finds the underlying value of a lambda expression. - * + * * This function recursively finds the underlying value of a lambda expression, * particularly useful for lookUps that may wrap other expressions. * @@ -1598,10 +1649,10 @@ static int findUnderlyingType(LamExp *exp) { */ static LamExp *findUnderlyingValue(LamExp *exp) { switch (exp->type) { - case LAMEXP_TYPE_LOOKUP: - return findUnderlyingValue(getLamExp_LookUp(exp)->exp); - default: - return exp; + case LAMEXP_TYPE_LOOKUP: + return findUnderlyingValue(getLamExp_LookUp(exp)->exp); + default: + return exp; } } @@ -1625,8 +1676,10 @@ static void checkLamTagPresent(HashSymbol *tag, AstTaggedExpressions *astTags) { * @param lamTags The list of lambda tags to check. * @param astTags The list of AST tags to search. */ -static void checkAllTagsPresent(LamTypeTags *lamTags, AstTaggedExpressions *astTags) { - if (lamTags == NULL) return; +static void checkAllTagsPresent(LamTypeTags *lamTags, + AstTaggedExpressions *astTags) { + if (lamTags == NULL) + return; checkLamTagPresent(lamTags->tag, astTags); checkAllTagsPresent(lamTags->next, astTags); } @@ -1640,17 +1693,21 @@ static void checkAstTagPresent(LamTypeTags *lamTags, HashSymbol *astTag) { if (lamTags == NULL) { cant_happen("missing constructor tag %s", astTag->name); } - if (astTag == lamTags->tag) return; + if (astTag == lamTags->tag) + return; checkAstTagPresent(lamTags->next, astTag); } /** - * @brief Checks if any unrecognised AST tags are present in the list of lambda tags. + * @brief Checks if any unrecognised AST tags are present in the list of lambda + * tags. * @param lamTags The list of lambda tags to check. * @param astTags The list of AST tags to search. */ -static void checkNoUnrecognisedTags(LamTypeTags *lamTags, AstTaggedExpressions *astTags) { - if (astTags == NULL) return; +static void checkNoUnrecognisedTags(LamTypeTags *lamTags, + AstTaggedExpressions *astTags) { + if (astTags == NULL) + return; checkAstTagPresent(lamTags, astTags->tag); checkNoUnrecognisedTags(lamTags, astTags->next); } @@ -1661,9 +1718,10 @@ static void checkNoUnrecognisedTags(LamTypeTags *lamTags, AstTaggedExpressions * * @param astTag The AST tag to search for. */ static void checkTagNotDuplicate(HashSymbol *tag, AstTaggedExpressions *tags) { - if (tags == NULL) return; + if (tags == NULL) + return; if (tag == tags->tag) { - conversionError(CPI(tags), "duplicate tag %s", tag->name); + can_happen(CPI(tags), "duplicate tag %s", tag->name); return; } checkTagNotDuplicate(tag, tags->next); @@ -1674,7 +1732,8 @@ static void checkTagNotDuplicate(HashSymbol *tag, AstTaggedExpressions *tags) { * @param tags The list of AST tags to check. */ static void checkNoDuplicateTags(AstTaggedExpressions *tags) { - if (tags == NULL) return; + if (tags == NULL) + return; checkTagNotDuplicate(tags->tag, tags->next); checkNoDuplicateTags(tags->next); } @@ -1685,28 +1744,34 @@ static void checkNoDuplicateTags(AstTaggedExpressions *tags) { * @param tags The list of tagged expressions to search. * @return The tagged expression. */ -static AstExpression *findTaggedExpression(HashSymbol *tag, AstTaggedExpressions *tags) { +static AstExpression *findTaggedExpression(HashSymbol *tag, + AstTaggedExpressions *tags) { #ifdef SAFETY_CHECKS if (tags == NULL) { cant_happen("cannot find value for tag %s", tag->name); } #endif - if (tag == tags->tag) return tags->expression; + if (tag == tags->tag) + return tags->expression; return findTaggedExpression(tag, tags->next); } /** - * @brief Arranges the AST tagged expressions in the canonical order of the lambda tags. - * + * @brief Arranges the AST tagged expressions in the canonical order of the + * lambda tags. + * * The result is a normal function application, without tags. - * + * * @param lamTags The list of lambda tags to arrange. * @param astTags The list of AST tags to search. * @param env The lambda context. */ -static LamArgs *convertTagsToArgs(LamTypeTags *lamTags, AstTaggedExpressions *astTags, LamContext *env) { +static LamArgs *convertTagsToArgs(LamTypeTags *lamTags, + AstTaggedExpressions *astTags, + LamContext *env) { // lamTags are in canonical order - if (lamTags == NULL) return NULL; + if (lamTags == NULL) + return NULL; LamArgs *rest = convertTagsToArgs(lamTags->next, astTags, env); int save = PROTECT(rest); AstExpression *expression = findTaggedExpression(lamTags->tag, astTags); @@ -1718,7 +1783,8 @@ static LamArgs *convertTagsToArgs(LamTypeTags *lamTags, AstTaggedExpressions *as } /** - * @brief Allows a constructor application to be curried by wrapping it in a curried function application. + * @brief Allows a constructor application to be curried by wrapping it in a + * curried function application. * * Example: * (constructor4 arg1 arg2) => @@ -1729,15 +1795,16 @@ static LamArgs *convertTagsToArgs(LamTypeTags *lamTags, AstTaggedExpressions *as * @return The curried constructor application. */ static LamExp *makeConstructorApplication(LamExp *constructor, LamArgs *args) { - int nArgs = (int) countLamArgs(args); + int nArgs = (int)countLamArgs(args); LamExp *result; int arity = findUnderlyingArity(constructor); if (nArgs < arity) { - LamVarList *fargs = genSymVarList(CPI(constructor), arity); + SymbolList *fargs = genSymVarList(CPI(constructor), arity); int save = PROTECT(fargs); LamArgs *aargs = varListToList(fargs); PROTECT(aargs); - LamApply *innerApply = newLamApply(CPI(constructor), constructor, aargs); + LamApply *innerApply = + newLamApply(CPI(constructor), constructor, aargs); PROTECT(innerApply); LamExp *applyExp = newLamExp_Apply(CPI(innerApply), innerApply); PROTECT(applyExp); @@ -1751,8 +1818,9 @@ static LamExp *makeConstructorApplication(LamExp *constructor, LamArgs *args) { return result; } /** - * @brief Creates a structure application from a constructor and a list of tagged expressions. - * + * @brief Creates a structure application from a constructor and a list of + * tagged expressions. + * * This function checks that the constructor is indeed a structure constructor, * verifies that all tags are present, checks for duplicates, and then creates * the application expression. @@ -1763,25 +1831,28 @@ static LamExp *makeConstructorApplication(LamExp *constructor, LamArgs *args) { * @return The resulting lambda expression for the structure application. */ -static LamExp *makeStructureApplication(LamExp *constructor, AstTaggedExpressions *tags, LamContext *env) { +static LamExp *makeStructureApplication(LamExp *constructor, + AstTaggedExpressions *tags, + LamContext *env) { if (getLamExp_Constructor(constructor)->tags == NULL) { - conversionError(CPI(constructor), "non-struct constructor applied to struct"); + can_happen(CPI(constructor), + "non-struct constructor applied to struct"); return lamExpError(CPI(tags)); } checkAllTagsPresent(getLamExp_Constructor(constructor)->tags, tags); checkNoUnrecognisedTags(getLamExp_Constructor(constructor)->tags, tags); checkNoDuplicateTags(tags); int arity = findUnderlyingArity(constructor); - int nArgs = (int) countAstTaggedExpressions(tags); + int nArgs = (int)countAstTaggedExpressions(tags); if (nArgs != arity) { - conversionError(CPI(constructor), "wrong number of args in structure application"); + can_happen(CPI(constructor), + "wrong number of args in structure application"); return lamExpError(CPI(tags)); } - LamArgs *args = convertTagsToArgs(getLamExp_Constructor(constructor)->tags, tags, env); + LamArgs *args = + convertTagsToArgs(getLamExp_Constructor(constructor)->tags, tags, env); int save = PROTECT(args); - LamApply *apply = newLamApply(CPI(constructor), constructor, args); - PROTECT(apply); - LamExp *result = newLamExp_Apply(CPI(apply), apply); + LamExp *result = makeLamExp_Apply(CPI(constructor), constructor, args); UNPROTECT(save); return result; } @@ -1789,26 +1860,27 @@ static LamExp *makeStructureApplication(LamExp *constructor, AstTaggedExpression * @brief Finds a constructor in the lambda context. * * This function looks up a constructor by its name in the given lambda context. - * If the constructor is a lookUp, find the constructor in the referenced nameSpace. + * If the constructor is a lookUp, find the constructor in the referenced + * nameSpace. * * @param los The lookUp or symbol to find. * @param env The lambda context. * @return The found constructor information, or NULL if not found. */ -static LamTypeConstructorInfo *findConstructor(AstLookUpOrSymbol *los, LamContext *env) { +static LamTypeConstructorInfo *findConstructor(AstLookUpOrSymbol *los, + LamContext *env) { switch (los->type) { - case AST_LOOKUPORSYMBOL_TYPE_SYMBOL:{ - return lookUpConstructorInLamContext(env, getAstLookUpOrSymbol_Symbol(los)); - } - break; - case AST_LOOKUPORSYMBOL_TYPE_LOOKUP:{ - AstLookUpSymbol *lookUp = getAstLookUpOrSymbol_LookUp(los); - LamContext *nsEnv = lookUpNameSpaceInLamContext(env, lookUp->nsId); - return lookUpConstructorInLamContext(nsEnv, lookUp->symbol); - } - break; - default: - cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); + case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: { + return lookUpConstructorInLamContext(env, + getAstLookUpOrSymbol_Symbol(los)); + } break; + case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: { + AstLookUpSymbol *lookUp = getAstLookUpOrSymbol_LookUp(los); + LamContext *nsEnv = lookUpNameSpaceInLamContext(env, lookUp->nsId); + return lookUpConstructorInLamContext(nsEnv, lookUp->symbol); + } break; + default: + cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); } } @@ -1822,15 +1894,18 @@ static LamTypeConstructorInfo *findConstructor(AstLookUpOrSymbol *los, LamContex static LamExp *convertStructure(AstStruct *structure, LamContext *env) { LamTypeConstructorInfo *info = findConstructor(structure->symbol, env); if (info == NULL) { - conversionError(CPI(structure), "cannot find constructor"); + can_happen(CPI(structure), "cannot find constructor"); return lamExpError(CPI(structure)); } LamExp *constructor = newLamExp_Constructor(CPI(info), info); int save = PROTECT(constructor); - LamExp *result = makeStructureApplication(constructor, structure->expressions, env); + LamExp *result = + makeStructureApplication(constructor, structure->expressions, env); if (structure->symbol->type == AST_LOOKUPORSYMBOL_TYPE_LOOKUP) { PROTECT(result); - LamLookUp *lookUp = newLamLookUp(CPI(result), info->nsId, getAstLookUpOrSymbol_LookUp(structure->symbol)->symbol, result); + LamLookUp *lookUp = newLamLookUp( + CPI(result), info->nsId, + getAstLookUpOrSymbol_LookUp(structure->symbol)->symbol, result); PROTECT(lookUp); result = newLamExp_LookUp(CPI(lookUp), lookUp); } @@ -1856,38 +1931,41 @@ static LamExp *convertFunCall(AstFunCall *funCall, LamContext *env) { LamExp *function = convertExpression(funCall->function, env); PROTECT(function); LamExp *result = NULL; - // If the callee is a nameSpaced lookUp, check macro-ness in that nameSpace env + // If the callee is a nameSpaced lookUp, check macro-ness in that nameSpace + // env if (function->type == LAMEXP_TYPE_LOOKUP) { - LamContext *nsEnv = lookUpNameSpaceInLamContext(env, getLamExp_LookUp(function)->nsId); + LamContext *nsEnv = + lookUpNameSpaceInLamContext(env, getLamExp_LookUp(function)->nsId); LamExp *under = findUnderlyingValue(function); - if (under->type == LAMEXP_TYPE_VAR && isMacro(getLamExp_Var(under), nsEnv)) { - result = thunkMacroExp(CPI(funCall), function, args); + if (under->type == LAMEXP_TYPE_VAR && + isLazy(getLamExp_Var(under), nsEnv)) { + result = thunkLazyExp(CPI(funCall), function, args); UNPROTECT(save); return result; } } switch (findUnderlyingType(function)) { - case LAMEXP_TYPE_VAR:{ - LamExp *symbol = findUnderlyingValue(function); - result = makePrimApp(CPI(funCall), getLamExp_Var(symbol), args, env); - if (result != NULL) { - UNPROTECT(save); - return result; - } - result = makeApplication(function, args); - UNPROTECT(save); - return result; - } - case LAMEXP_TYPE_CONSTRUCTOR:{ - result = makeConstructorApplication(function, args); - UNPROTECT(save); - return result; - } - default:{ - result = makeApplication(function, args); + case LAMEXP_TYPE_VAR: { + LamExp *symbol = findUnderlyingValue(function); + result = makePrimApp(CPI(funCall), getLamExp_Var(symbol), args, env); + if (result != NULL) { UNPROTECT(save); return result; } + result = makeApplication(function, args); + UNPROTECT(save); + return result; + } + case LAMEXP_TYPE_CONSTRUCTOR: { + result = makeConstructorApplication(function, args); + UNPROTECT(save); + return result; + } + default: { + result = makeApplication(function, args); + UNPROTECT(save); + return result; + } } } @@ -1904,16 +1982,14 @@ static AstFarg *rewriteAstFarg(AstFarg *arg, LamContext *env); static AstFarg *rewriteAstNamed(AstNamedArg *namedArg, LamContext *env) { AstFarg *arg = rewriteAstFarg(namedArg->arg, env); int save = PROTECT(arg); - AstNamedArg *this = newAstNamedArg(CPI(namedArg), namedArg->name, arg); - PROTECT(this); - AstFarg *res = newAstFarg_Named(CPI(this), this); + AstFarg *res = makeAstFarg_Named(CPI(namedArg), namedArg->name, arg); UNPROTECT(save); return res; } /** * @brief Rewrites the components of an AstUnpack. - * + * * @param unpack The AstUnpack to rewrite. * @param env The lambda context to use for rewriting. * @return The rewritten AstUnpack, wrapped in an AstFarg. @@ -1921,16 +1997,14 @@ static AstFarg *rewriteAstNamed(AstNamedArg *namedArg, LamContext *env) { static AstFarg *rewriteAstUnpack(AstUnpack *unpack, LamContext *env) { AstFargList *args = rewriteAstFargList(unpack->argList, env); int save = PROTECT(args); - AstUnpack *this = newAstUnpack(CPI(unpack), unpack->symbol, args); - PROTECT(this); - AstFarg *res = newAstFarg_Unpack(CPI(this), this); + AstFarg *res = makeAstFarg_Unpack(CPI(unpack), unpack->symbol, args); UNPROTECT(save); return res; } /** * @brief Retrieves an AstFarg from an AST tagged argument list. - * + * * This function searches through the tagged argument list for a * matching tag and returns the corresponding AstFarg. * If no matching tag is found, a wildCard AstFarg is returned. @@ -1942,7 +2016,9 @@ static AstFarg *rewriteAstUnpack(AstUnpack *unpack, LamContext *env) { * @param I The parser information. * @return The corresponding AstFarg, or a wildCard if not found. */ -static AstFarg *getAstFargFromTaggedArgList(HashSymbol *tag, AstTaggedArgList *list, LamContext *env, ParserInfo I) { +static AstFarg *getAstFargFromTaggedArgList(HashSymbol *tag, + AstTaggedArgList *list, + LamContext *env, ParserInfo I) { if (list == NULL) { return newAstFarg_WildCard(I); } @@ -1954,20 +2030,24 @@ static AstFarg *getAstFargFromTaggedArgList(HashSymbol *tag, AstTaggedArgList *l /** * @brief Rewrites an AST tagged argument list into a plain AstFargList. - * + * * The canonical positions of the tags dictate the order of the arguments. * The actual unpacking is done by `getAstFargFromTaggedArgList`. - * + * * @param allTags The list of all tags of the constructor in canonical order. * @param argTags The AST tagged argument list to rewrite. * @param env The lambda context to use for rewriting. * @return The rewritten AST tagged argument list, wrapped in an AstFargList. */ -static AstFargList *rewriteAstTaggedArgList(LamTypeTags *allTags, AstTaggedArgList *argTags, LamContext *env) { - if (allTags == NULL) return NULL; +static AstFargList *rewriteAstTaggedArgList(LamTypeTags *allTags, + AstTaggedArgList *argTags, + LamContext *env) { + if (allTags == NULL) + return NULL; AstFargList *next = rewriteAstTaggedArgList(allTags->next, argTags, env); int save = PROTECT(next); - AstFarg *arg = getAstFargFromTaggedArgList(allTags->tag, argTags, env, CPI(argTags)); + AstFarg *arg = + getAstFargFromTaggedArgList(allTags->tag, argTags, env, CPI(argTags)); PROTECT(arg); AstFargList *this = newAstFargList(CPI(argTags), arg, next); UNPROTECT(save); @@ -1976,25 +2056,25 @@ static AstFargList *rewriteAstTaggedArgList(LamTypeTags *allTags, AstTaggedArgLi /** * @brief Rewrites an AST unpack struct argument into a plain AstUnpack. - * + * * The canonical positions of the tags dictate the order of the arguments. * The actual unpacking is done by `rewriteAstTaggedArgList`. - * + * * @param structure The AST unpack struct argument to rewrite. * @param env The lambda context to use for rewriting. * @return The rewritten AST unpack struct argument, wrapped in an AstFarg. */ -static AstFarg *rewriteAstUnpackStruct(AstUnpackStruct *structure, LamContext *env) { +static AstFarg *rewriteAstUnpackStruct(AstUnpackStruct *structure, + LamContext *env) { LamTypeConstructorInfo *info = findConstructor(structure->symbol, env); if (info->tags == NULL) { - conversionError(CPI(structure), "constructor not a struct"); + can_happen(CPI(structure), "constructor not a struct"); return newAstFarg_WildCard(CPI(structure)); } - AstFargList *args = rewriteAstTaggedArgList(info->tags, structure->argList, env); + AstFargList *args = + rewriteAstTaggedArgList(info->tags, structure->argList, env); int save = PROTECT(args); - AstUnpack *unpack = newAstUnpack(CPI(structure), structure->symbol, args); - PROTECT(unpack); - AstFarg *res = newAstFarg_Unpack(CPI(unpack), unpack); + AstFarg *res = makeAstFarg_Unpack(CPI(structure), structure->symbol, args); UNPROTECT(save); return res; } @@ -2014,47 +2094,50 @@ static AstFarg *rewriteAstTuple(AstFargList *tuple, LamContext *env) { } /** - * @brief Rewrites an AST formal argument into a form more suitable for tpmc conversion. - * + * @brief Rewrites an AST formal argument into a form more suitable for tpmc + * conversion. + * * Named arguments are recursed into. * Unpack arguments are recursed into. * Tuple arguments are recursed into. * UnpackStruct arguments are replaced with unpack arguments, * hence the recursion. - * + * * @param arg The AST formal argument to rewrite. * @param env The lambda context to use for rewriting. * @return The rewritten AST formal argument. */ static AstFarg *rewriteAstFarg(AstFarg *arg, LamContext *env) { switch (arg->type) { - case AST_FARG_TYPE_WILDCARD: - case AST_FARG_TYPE_SYMBOL: - case AST_FARG_TYPE_NUMBER: - case AST_FARG_TYPE_CHARACTER: - case AST_FARG_TYPE_LOOKUP: - return arg; - case AST_FARG_TYPE_NAMED: - return rewriteAstNamed(getAstFarg_Named(arg), env); - case AST_FARG_TYPE_UNPACK: - return rewriteAstUnpack(getAstFarg_Unpack(arg), env); - case AST_FARG_TYPE_UNPACKSTRUCT: - return rewriteAstUnpackStruct(getAstFarg_UnpackStruct(arg), env); - case AST_FARG_TYPE_TUPLE: - return rewriteAstTuple(getAstFarg_Tuple(arg), env); - default: - cant_happen("unrecognized %s", astFargTypeName(arg->type)); - } -} - -/** - * @brief Rewrites an AST formal argument list into a form more suitable for tpmc conversion. + case AST_FARG_TYPE_WILDCARD: + case AST_FARG_TYPE_SYMBOL: + case AST_FARG_TYPE_NUMBER: + case AST_FARG_TYPE_CHARACTER: + case AST_FARG_TYPE_LOOKUP: + return arg; + case AST_FARG_TYPE_NAMED: + return rewriteAstNamed(getAstFarg_Named(arg), env); + case AST_FARG_TYPE_UNPACK: + return rewriteAstUnpack(getAstFarg_Unpack(arg), env); + case AST_FARG_TYPE_UNPACKSTRUCT: + return rewriteAstUnpackStruct(getAstFarg_UnpackStruct(arg), env); + case AST_FARG_TYPE_TUPLE: + return rewriteAstTuple(getAstFarg_Tuple(arg), env); + default: + cant_happen("unrecognized %s", astFargTypeName(arg->type)); + } +} + +/** + * @brief Rewrites an AST formal argument list into a form more suitable for + * tpmc conversion. * @param args The AST formal argument list to rewrite. * @param env The lambda context to use for rewriting. * @return The rewritten AST formal argument list. */ static AstFargList *rewriteAstFargList(AstFargList *args, LamContext *env) { - if (args == NULL) return NULL; + if (args == NULL) + return NULL; AstFargList *next = rewriteAstFargList(args->next, env); int save = PROTECT(next); AstFarg *arg = rewriteAstFarg(args->arg, env); @@ -2065,23 +2148,25 @@ static AstFargList *rewriteAstFargList(AstFargList *args, LamContext *env) { } /** - * @brief Converts the bodies of a composite function into a single lambda expression. - * + * @brief Converts the bodies of a composite function into a single lambda + * expression. + * * This function calls into the TPMC code to convert the formal arguments and * separate function bodies to a single pattern matcher dispatching to the * appropriate body. - * + * * @param nArgs The number of arguments for the function. * @param fun The composite function to convert. * @param env The lambda context to use for conversion. * @return The converted composite function. */ -static LamLam *convertCompositeBodies(int nArgs, AstCompositeFunction *fun, +static LamLam *convertCompositeBodies(ParserInfo PI, int nArgs, + AstCompositeFunction *fun, LamContext *env) { ENTER(convertCompositeBodies); int nBodies = countAstCompositeFunction(fun); if (nBodies == 0) { - can_happen("empty composite function"); + can_happen(PI, "empty composite function"); LEAVE(convertCompositeBodies); return NULL; } @@ -2096,7 +2181,8 @@ static LamLam *convertCompositeBodies(int nArgs, AstCompositeFunction *fun, argLists[i] = rewriteAstFargList(func->argList, env); PROTECT(argLists[i]); } - LamLam *result = tpmcConvert(fun->unsafe, CPI(fun), nArgs, nBodies, argLists, actions, env); + LamLam *result = tpmcConvert(fun->unsafe, CPI(fun), nArgs, nBodies, + argLists, actions, env); PROTECT(result); FREE_ARRAY(LamExp *, actions, nBodies); FREE_ARRAY(AstFargList *, argLists, nBodies); @@ -2112,14 +2198,15 @@ static LamLam *convertCompositeBodies(int nArgs, AstCompositeFunction *fun, * @param env The lambda context to use for conversion. * @return The resulting lambda expression for the composite function. */ -static LamExp *convertCompositeFun(ParserInfo PI, AstCompositeFunction *fun, LamContext *env) { +static LamExp *convertCompositeFun(ParserInfo PI, AstCompositeFunction *fun, + LamContext *env) { ENTER(convertCompositeFun); if (fun == NULL) { - conversionError(PI, "composite function with no components"); + can_happen(PI, "composite function with no components"); return lamExpError(PI); } int nArgs = countAstFargList(fun->function->argList); - LamLam *lambda = convertCompositeBodies(nArgs, fun, env); + LamLam *lambda = convertCompositeBodies(PI, nArgs, fun, env); DEBUG("convertCompositeBodies returned %p", lambda); int save = PROTECT(lambda); LamExp *result = newLamExp_Lam(CPI(lambda), lambda); @@ -2135,10 +2222,12 @@ static LamExp *convertCompositeFun(ParserInfo PI, AstCompositeFunction *fun, Lam * @param env The lambda context to use for conversion. * @return The resulting lambda expression for the symbol. */ -static LamExp *convertSymbol(ParserInfo I, HashSymbol *symbol, LamContext *env) { +static LamExp *convertSymbol(ParserInfo I, HashSymbol *symbol, + LamContext *env) { ENTER(convertSymbol); LamExp *result = makeConstructor(symbol, env); - DEBUG("convertSymbol %s %d - %s: %s", I.fileName, I.lineNo, symbol->name, result ? "constructor" : "variable"); + DEBUG("convertSymbol %s %d - %s: %s", I.fileName, I.lineNo, symbol->name, + result ? "constructor" : "variable"); if (result == NULL) { result = newLamExp_Var(I, symbol); } @@ -2147,37 +2236,55 @@ static LamExp *convertSymbol(ParserInfo I, HashSymbol *symbol, LamContext *env) } /** - * @brief Converts an annotated symbol (hygienic operator wrapper) into a lambda expression. - * - * This handles the case where a hygienic operator wrapper ($opN) wraps a type constructor. - * If the original implementation is a type constructor, we return a reference to that constructor - * directly, allowing it to be used in patterns. Otherwise, we return a reference to the hygienic - * wrapper function. - * - * @param annotated The annotated symbol containing both wrapper and original implementation. + * @brief Converts an annotated symbol (hygienic operator wrapper) into a lambda + * expression. + * + * This handles the case where a hygienic operator wrapper ($opN) wraps a type + * constructor. If the original implementation is a type constructor, we return + * a reference to that constructor directly, allowing it to be used in patterns. + * Otherwise, we return a reference to the hygienic wrapper function. + * + * @param annotated The annotated symbol containing both wrapper and original + * implementation. * @param env The lambda context to use for conversion. - * @return The resulting lambda expression (either constructor or variable reference). + * @return The resulting lambda expression (either constructor or variable + * reference). */ -static LamExp *convertAnnotatedSymbol(AstAnnotatedSymbol *annotated, LamContext *env) { +static LamExp *convertAnnotatedSymbol(AstAnnotatedSymbol *annotated, + LamContext *env) { ENTER(convertAnnotatedSymbol); LamExp *result = NULL; - - // Check if the original implementation is a bare symbol that's a type constructor + + // Check if the original implementation is a bare symbol that's a type + // constructor if (annotated->originalImpl->type == AST_EXPRESSION_TYPE_SYMBOL) { - HashSymbol *originalSym = getAstExpression_Symbol(annotated->originalImpl); + HashSymbol *originalSym = + getAstExpression_Symbol(annotated->originalImpl); LamExp *constructor = makeConstructor(originalSym, env); if (constructor != NULL) { - // Original is a type constructor - return it directly for pattern matching - DEBUG("convertAnnotatedSymbol: %s wraps constructor %s, using constructor directly", + // Original is a type constructor - return it directly for pattern + // matching + DEBUG("convertAnnotatedSymbol: %s wraps constructor %s, using " + "constructor directly", annotated->symbol->name, originalSym->name); result = constructor; LEAVE(convertAnnotatedSymbol); return result; } + // Non-lazy operator: resolve original symbol directly at call site + if (!annotated->isLazy) { + DEBUG("convertAnnotatedSymbol: %s is non-lazy, using original " + "symbol %s directly", + annotated->symbol->name, originalSym->name); + result = newLamExp_Var(CPI(annotated), originalSym); + LEAVE(convertAnnotatedSymbol); + return result; + } } - - // Not a constructor - use the hygienic wrapper symbol - DEBUG("convertAnnotatedSymbol: %s is not a constructor wrapper, using hygienic function", + + // Lazy operator: use the hygienic wrapper symbol + DEBUG("convertAnnotatedSymbol: %s is not a constructor wrapper, using " + "hygienic function", annotated->symbol->name); HashSymbol *symbol = annotated->symbol; result = newLamExp_Var(CPI(annotated), symbol); @@ -2215,10 +2322,10 @@ static LamExp *convertAssertion(AstExpression *value, LamContext *env) { /** * @brief Converts an error expression into a lambda expression. - * + * * The error in question is a runtime error caused by a non-exhaustive * pattern match failure in an unsafe function. - * + * * @param value The error expression to convert. * @param env The lambda context to use for conversion. * @return The resulting lambda expression for the error. @@ -2255,80 +2362,86 @@ static LamExp *convertExpression(AstExpression *expression, LamContext *env) { ENTER(convertExpression); LamExp *result = NULL; switch (expression->type) { - case AST_EXPRESSION_TYPE_BACK: - DEBUG("back"); - result = newLamExp_Back(CPI(expression)); - break; - case AST_EXPRESSION_TYPE_FUNCALL: - DEBUG("funcall"); - result = convertFunCall(getAstExpression_FunCall(expression), env); - break; - case AST_EXPRESSION_TYPE_ANNOTATEDSYMBOL: - DEBUG("annotatedSymbol"); - result = convertAnnotatedSymbol(getAstExpression_AnnotatedSymbol(expression), env); - break; - case AST_EXPRESSION_TYPE_SYMBOL: - DEBUG("symbol"); - result = convertSymbol(CPI(expression), getAstExpression_Symbol(expression), env); - break; - case AST_EXPRESSION_TYPE_NUMBER: - DEBUG("number"); - result = newLamExp_BigInteger(CPI(expression), getAstExpression_Number(expression)); - break; - case AST_EXPRESSION_TYPE_CHARACTER: - DEBUG("character"); - result = newLamExp_Character(CPI(expression), getAstExpression_Character(expression)); - break; - case AST_EXPRESSION_TYPE_ENV: - DEBUG("env"); - result = newLamExp_Env(CPI(expression)); - break; - case AST_EXPRESSION_TYPE_FUN: - DEBUG("fun"); - result = convertCompositeFun(CPI(expression), getAstExpression_Fun(expression), env); - break; - case AST_EXPRESSION_TYPE_NEST: - DEBUG("nest"); - result = convertNest(getAstExpression_Nest(expression), env); - break; - case AST_EXPRESSION_TYPE_IFF: - DEBUG("iff"); - result = lamConvertIff(getAstExpression_Iff(expression), env); - break; - case AST_EXPRESSION_TYPE_PRINT: - DEBUG("print"); - result = lamConvertPrint(getAstExpression_Print(expression), env); - break; - case AST_EXPRESSION_TYPE_TYPEOF: - DEBUG("typeOf"); - result = lamConvertTypeOf(getAstExpression_TypeOf(expression), env); - break; - case AST_EXPRESSION_TYPE_TUPLE: - DEBUG("tuple"); - result = lamConvertTuple(CPI(expression), getAstExpression_Tuple(expression), env); - break; - case AST_EXPRESSION_TYPE_LOOKUP: - DEBUG("lookUp"); - result = lamConvertLookUp(getAstExpression_LookUp(expression), env); - break; - case AST_EXPRESSION_TYPE_STRUCTURE: - DEBUG("structure"); - result = convertStructure(getAstExpression_Structure(expression), env); - break; - case AST_EXPRESSION_TYPE_ASSERTION: - result = convertAssertion(getAstExpression_Assertion(expression), env); - break; - case AST_EXPRESSION_TYPE_ERROR: - result = convertError(getAstExpression_Error(expression), env); - break; - case AST_EXPRESSION_TYPE_WILDCARD: - conversionError(CPI(expression), "cannot use wildCard '_' as a variable name"); - result = convertSymbol(CPI(expression), errorSymbol(), env); - break; - default: - cant_happen - ("unrecognised expression type %s", - astExpressionTypeName(expression->type)); + case AST_EXPRESSION_TYPE_BACK: + DEBUG("back"); + result = newLamExp_Back(CPI(expression)); + break; + case AST_EXPRESSION_TYPE_FUNCALL: + DEBUG("funcall"); + result = convertFunCall(getAstExpression_FunCall(expression), env); + break; + case AST_EXPRESSION_TYPE_ANNOTATEDSYMBOL: + DEBUG("annotatedSymbol"); + result = convertAnnotatedSymbol( + getAstExpression_AnnotatedSymbol(expression), env); + break; + case AST_EXPRESSION_TYPE_SYMBOL: + DEBUG("symbol"); + result = convertSymbol(CPI(expression), + getAstExpression_Symbol(expression), env); + break; + case AST_EXPRESSION_TYPE_NUMBER: + DEBUG("number"); + result = newLamExp_BigInteger(CPI(expression), + getAstExpression_Number(expression)); + break; + case AST_EXPRESSION_TYPE_CHARACTER: + DEBUG("character"); + result = newLamExp_Character(CPI(expression), + getAstExpression_Character(expression)); + break; + case AST_EXPRESSION_TYPE_ENV: + DEBUG("env"); + result = newLamExp_Env(CPI(expression)); + break; + case AST_EXPRESSION_TYPE_FUN: + DEBUG("fun"); + result = convertCompositeFun(CPI(expression), + getAstExpression_Fun(expression), env); + break; + case AST_EXPRESSION_TYPE_NEST: + DEBUG("nest"); + result = convertNest(getAstExpression_Nest(expression), env); + break; + case AST_EXPRESSION_TYPE_IFF: + DEBUG("iff"); + result = lamConvertIff(getAstExpression_Iff(expression), env); + break; + case AST_EXPRESSION_TYPE_PRINT: + DEBUG("print"); + result = lamConvertPrint(getAstExpression_Print(expression), env); + break; + case AST_EXPRESSION_TYPE_TYPEOF: + DEBUG("typeOf"); + result = lamConvertTypeOf(getAstExpression_TypeOf(expression), env); + break; + case AST_EXPRESSION_TYPE_TUPLE: + DEBUG("tuple"); + result = lamConvertTuple(CPI(expression), + getAstExpression_Tuple(expression), env); + break; + case AST_EXPRESSION_TYPE_LOOKUP: + DEBUG("lookUp"); + result = lamConvertLookUp(getAstExpression_LookUp(expression), env); + break; + case AST_EXPRESSION_TYPE_STRUCTURE: + DEBUG("structure"); + result = convertStructure(getAstExpression_Structure(expression), env); + break; + case AST_EXPRESSION_TYPE_ASSERTION: + result = convertAssertion(getAstExpression_Assertion(expression), env); + break; + case AST_EXPRESSION_TYPE_ERROR: + result = convertError(getAstExpression_Error(expression), env); + break; + case AST_EXPRESSION_TYPE_WILDCARD: + can_happen(CPI(expression), + "cannot use wildCard '_' as a variable name"); + result = convertSymbol(CPI(expression), errorSymbol(), env); + break; + default: + cant_happen("unrecognised expression type %s", + astExpressionTypeName(expression->type)); } LEAVE(convertExpression); return result; @@ -2347,7 +2460,7 @@ static LamArgs *convertExpressions(AstExpressions *expressions, LamArgs *next = convertExpressions(expressions->next, env); int save = PROTECT(next); LamExp *exp = convertExpression(expressions->expression, env); - (void) PROTECT(exp); + (void)PROTECT(exp); LamArgs *this = newLamArgs(CPI(exp), exp, next); UNPROTECT(save); return this; @@ -2366,8 +2479,9 @@ static LamSequence *convertSequence(AstExpressions *expressions, LamSequence *next = convertSequence(expressions->next, env); int save = PROTECT(next); LamExp *exp = convertExpression(expressions->expression, env); - (void) PROTECT(exp); - LamSequence *this = (exp == NULL) ? NULL : newLamSequence(CPI(exp), exp, next); + (void)PROTECT(exp); + LamSequence *this = + (exp == NULL) ? NULL : newLamSequence(CPI(exp), exp, next); UNPROTECT(save); return this; } diff --git a/src/lambda_cps.h b/src/lambda_cps.h index 2bd9bfc2..304699ec 100644 --- a/src/lambda_cps.h +++ b/src/lambda_cps.h @@ -1,39 +1,39 @@ #ifndef cekf_lambda_cps_h -# define cekf_lambda_cps_h +#define cekf_lambda_cps_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2025 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 "lambda.h" #include "cps_kont.h" +#include "minlam.h" -LamExp *cpsTk(LamExp *, CpsKont *); -LamArgs *appendLamArg(LamArgs *, LamExp *); -LamExp *makeVar(ParserInfo, char *); -LamVarList *appendLamVar(ParserInfo, LamVarList *, HashSymbol *); -LamExp *cpsTs_k(LamExp *, CpsKont *); -bool isAexpr(LamExp *); -LamExp *cpsTc(LamExp *, LamExp *); -LamExp *cpsM(LamExp *); -LamBindings *mapMOverBindings(LamBindings *); -LamMatchList *mapTcOverMatchCases(LamMatchList *, LamExp *); -void cpsUnzipLamBindings(LamBindings *, LamVarList **, LamArgs **); -LamExp *cpsNestLets(LamBindings *, LamExp *); -LamExp *nsaToArgs(LamNameSpaceArray *nsa); -LamNameSpaceArray *argsToNsa(LamExp *seq); +MinExp *cpsTk(MinExp *, CpsKont *); +MinExprList *appendMinArg(MinExprList *, MinExp *); +MinExp *makeVar(ParserInfo, char *); +SymbolList *appendMinVar(ParserInfo, SymbolList *, HashSymbol *); +MinExp *cpsTs_k(MinExp *, CpsKont *); +bool isAexpr(MinExp *); +MinExp *cpsTc(MinExp *, MinExp *); +MinExp *cpsM(MinExp *); +MinBindings *mapMOverBindings(MinBindings *); +MinMatchList *mapTcOverMatchCases(MinMatchList *, MinExp *); +void cpsUnzipMinBindings(MinBindings *, SymbolList **, MinExprList **); +MinExp *cpsNestLets(MinBindings *, MinExp *); +MinExp *nsaToArgs(MinNameSpaceArray *nsa); +MinNameSpaceArray *argsToNsa(MinExp *seq); #endif diff --git a/src/lambda_cpsTc.c b/src/lambda_cpsTc.c index 3ec63496..fd6a33e4 100644 --- a/src/lambda_cpsTc.c +++ b/src/lambda_cpsTc.c @@ -1,17 +1,17 @@ /* * CEKF - VM supporting amb * Copyright (C) 2022-2025 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 . * @@ -19,45 +19,35 @@ * Generated from src/lambda.yaml by tools/generate.py */ -#include "lambda.h" +#include "common.h" #include "memory.h" +#include "minlam.h" #include "symbol.h" -#include "common.h" -#include "lambda_cps.h" -#include "lambda_functions.h" #include "cps_kont.h" #include "cps_kont_impl.h" +#include "lambda_cps.h" +#include "lambda_functions.h" #ifdef DEBUG_LAMBDA_CPSTC -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif // Forward declarations -static LamExp *cpsTcTag(LamExp *node, LamExp *c); -static LamExp *cpsTcLamPrimApp(LamPrimApp *node, LamExp *c); -static LamExp *cpsTcLamSequence(LamSequence *node, LamExp *c); -static LamExp *cpsTcMakeTuple(LamArgs *node, LamExp *c); -static LamExp *cpsTcLamApply(LamApply *node, LamExp *c); -static LamExp *cpsTcLamLookUp(LamLookUp *node, LamExp *c); -static LamExp *cpsTcLamConstruct(LamConstruct *node, LamExp *c); -static LamExp *cpsTcLamDeconstruct(LamDeconstruct *node, LamExp *c); -static LamExp *cpsTcLamTupleIndex(LamTupleIndex *node, LamExp *c); -static LamExp *cpsTcMakeVec(LamMakeVec *node, LamExp *c); -static LamExp *cpsTcLamIff(LamIff *node, LamExp *c); -static LamExp *cpsTcLamCond(LamCond *node, LamExp *c); -static LamExp *cpsTcLamMatch(LamMatch *node, LamExp *c); -static LamExp *cpsTcLamLet(LamLet *node, LamExp *c); -static LamExp *cpsTcLamLetStar(LamLetStar *node, LamExp *c); -static LamExp *cpsTcLamLetRec(LamLetRec *node, LamExp *c); -static LamExp *cpsTcLamAmb(LamAmb *node, LamExp *c); -static LamExp *cpsTcLamPrint(LamPrint *node, LamExp *c); -static LamExp *cpsTcLamTypeOf(LamTypeOf *node, LamExp *c); -static LamExp *cpsTcLamTypeDefs(LamTypeDefs *node, LamExp *c); -static LamExp *cpsTcLamExp(LamExp *node, LamExp *c); -static LamExp *cpsTcLamNameSpaceArray(LamNameSpaceArray *node, LamExp *c); +static MinExp *cpsTcMinPrimApp(MinPrimApp *node, MinExp *c); +static MinExp *cpsTcMinSequence(MinExprList *node, MinExp *c); +static MinExp *cpsTcMinApply(MinApply *node, MinExp *c); +static MinExp *cpsTcMinLookUp(MinLookUp *node, MinExp *c); +static MinExp *cpsTcMakeVec(MinExprList *node, MinExp *c); +static MinExp *cpsTcMinIff(MinIff *node, MinExp *c); +static MinExp *cpsTcMinCond(MinCond *node, MinExp *c); +static MinExp *cpsTcMinMatch(MinMatch *node, MinExp *c); +static MinExp *cpsTcMinLetRec(MinLetRec *node, MinExp *c); +static MinExp *cpsTcMinAmb(MinAmb *node, MinExp *c); +static MinExp *cpsTcMinExp(MinExp *node, MinExp *c); +static MinExp *cpsTcMinNameSpaceArray(MinNameSpaceArray *node, MinExp *c); /* fn M { @@ -68,7 +58,7 @@ static LamExp *cpsTcLamNameSpaceArray(LamNameSpaceArray *node, LamExp *c); (x) { x } } */ -LamExp *cpsM(LamExp *node) { +MinExp *cpsM(MinExp *node) { ENTER(cpsM); if (node == NULL) { LEAVE(cpsM); @@ -76,54 +66,26 @@ LamExp *cpsM(LamExp *node) { } switch (node->type) { - case LAMEXP_TYPE_LAM: { - LamExp *c = makeVar(CPI(node), "k"); - int save = PROTECT(c); - LamVarList *args = appendLamVar(CPI(node), getLamExp_Lam(node)->args, getLamExp_Var(c)); - PROTECT(args); - LamExp *body = cpsTc(getLamExp_Lam(node)->exp, c); - PROTECT(body); - LamExp *result = makeLamExp_Lam(CPI(node), args, body); - UNPROTECT(save); - LEAVE(cpsM); - return result; - } - default: - LEAVE(cpsM); - return node; + case MINEXP_TYPE_LAM: { + MinExp *c = makeVar(CPI(node), "k"); + int save = PROTECT(c); + SymbolList *args = appendMinVar(CPI(node), getMinExp_Lam(node)->args, + getMinExp_Var(c)); + PROTECT(args); + MinExp *body = cpsTc(getMinExp_Lam(node)->exp, c); + PROTECT(body); + MinExp *result = makeMinExp_Lam(CPI(node), args, body); + UNPROTECT(save); + LEAVE(cpsM); + return result; } -} - -// Visitor implementations - -/* - (E.tag(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.tag(sexpr)]) - }) + default: + LEAVE(cpsM); + return node; } -*/ -static LamExp *cpsTcTag(LamExp *node, LamExp *c) { - ENTER(cpsTcTag); - CpsKont *k = makeKont_TcTag(c); - int save = PROTECT(k); - LamExp *result = cpsTk(node, k); - UNPROTECT(save); - LEAVE(cpsTcTag); - return result; } -LamExp *TcTagKont(LamExp *sexpr, TcTagKontEnv *env) { - ENTER(TcTagKont); - LamExp *tagged = newLamExp_Tag(CPI(sexpr), sexpr); - int save = PROTECT(tagged); - LamArgs *args = newLamArgs(CPI(tagged), tagged, NULL); - PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(tagged), env->c, args); - UNPROTECT(save); - LEAVE(TcTagKont); - return result; -} +// Visitor implementations /* (E.primapp(p, e1, e2)) { @@ -134,33 +96,33 @@ LamExp *TcTagKont(LamExp *sexpr, TcTagKontEnv *env) { }) } */ -static LamExp *cpsTcLamPrimApp(LamPrimApp *node, LamExp *c) { - ENTER(cpsTcLamPrimApp); +static MinExp *cpsTcMinPrimApp(MinPrimApp *node, MinExp *c) { + ENTER(cpsTcMinPrimApp); CpsKont *k = makeKont_TcPrimApp1(c, node->exp2, node->type); int save = PROTECT(k); - LamExp *result = cpsTk(node->exp1, k); + MinExp *result = cpsTk(node->exp1, k); UNPROTECT(save); - LEAVE(cpsTcLamPrimApp); + LEAVE(cpsTcMinPrimApp); return result; } -LamExp *TcPrimApp1Kont(LamExp *s1, TcPrimApp1KontEnv *env) { +MinExp *TcPrimApp1Kont(MinExp *s1, TcPrimApp1KontEnv *env) { ENTER(TcPrimApp1Kont); CpsKont *k = makeKont_TcPrimApp2(env->c, s1, env->p); int save = PROTECT(k); - LamExp *result = cpsTk(env->e2, k); + MinExp *result = cpsTk(env->e2, k); UNPROTECT(save); LEAVE(TcPrimApp1Kont); return result; } -LamExp *TcPrimApp2Kont(LamExp *s2, TcPrimApp2KontEnv *env) { +MinExp *TcPrimApp2Kont(MinExp *s2, TcPrimApp2KontEnv *env) { ENTER(TcPrimApp2Kont); - LamExp *primapp = makeLamExp_Prim(CPI(env->s1), env->p, env->s1, s2); + MinExp *primapp = makeMinExp_Prim(CPI(env->s1), env->p, env->s1, s2); int save = PROTECT(primapp); - LamArgs *args = newLamArgs(CPI(primapp), primapp, NULL); + MinExprList *args = newMinExprList(CPI(primapp), primapp, NULL); PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(primapp), env->c, args); + MinExp *result = makeMinExp_Apply(CPI(primapp), env->c, args); UNPROTECT(save); LEAVE(TcPrimApp2Kont); return result; @@ -174,68 +136,37 @@ LamExp *TcPrimApp2Kont(LamExp *s2, TcPrimApp2KontEnv *env) { }) } */ -static LamExp *cpsTcLamSequence(LamSequence *node, LamExp *c) { - ENTER(cpsTcLamSequence); +static MinExp *cpsTcMinSequence(MinExprList *node, MinExp *c) { + ENTER(cpsTcMinSequence); #ifdef SAFETY_CHECKS if (node == NULL) { - cant_happen("NULL node in cpsTcLamSequence"); + cant_happen("NULL node in cpsTcMinSequence"); } #endif - LamExp *result = NULL; + MinExp *result = NULL; int save = PROTECT(NULL); if (node->next == NULL) { - result = cpsTcLamExp(node->exp, c); + result = cpsTcMinExp(node->exp, c); } else { CpsKont *kont = makeKont_TcSequence(c, node->next); PROTECT(kont); result = cpsTk(node->exp, kont); } UNPROTECT(save); - LEAVE(cpsTcLamSequence); + LEAVE(cpsTcMinSequence); return result; } -LamExp *TcSequenceKont(LamExp *ignored, TcSequenceKontEnv *env) { +MinExp *TcSequenceKont(MinExp *ignored, TcSequenceKontEnv *env) { ENTER(TcSequenceKont); - LamExp *sequence = newLamExp_Sequence(CPI(ignored), env->exprs); + MinExp *sequence = newMinExp_Sequence(CPI(ignored), env->exprs); int save = PROTECT(sequence); - LamExp *result = cpsTcLamExp(sequence, env->c); + MinExp *result = cpsTcMinExp(sequence, env->c); UNPROTECT(save); LEAVE(TcSequenceKont); return result; } -/* - (E.make_tuple(args)) { - Ts_k(args, fn (sargs) { - E.apply(c, [E.make_tuple(sargs)]) - }) - } -*/ -static LamExp *cpsTcMakeTuple(LamArgs *node, LamExp *c) { - ENTER(cpsTcMakeTuple); - CpsKont *kont = makeKont_TcMakeTuple(c); - int save = PROTECT(kont); - LamExp *args = newLamExp_Args(CPI(node), node); - PROTECT(args); - LamExp *result = cpsTs_k(args, kont); - UNPROTECT(save); - LEAVE(cpsTcMakeTuple); - return result; -} - -LamExp *TcMakeTupleKont(LamExp *sargs, TcMakeTupleKontEnv *env) { - ENTER(TcMakeTupleKont); - LamExp *make_tuple = newLamExp_MakeTuple(CPI(sargs), getLamExp_Args(sargs)); - int save = PROTECT(make_tuple); - LamArgs *args = newLamArgs(CPI(sargs), make_tuple, NULL); - PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(sargs), env->c, args); - UNPROTECT(save); - LEAVE(TcMakeTupleKont); - return result; -} - /* (E.apply(f, es)) { T_k(f, fn(sf) { @@ -243,37 +174,37 @@ LamExp *TcMakeTupleKont(LamExp *sargs, TcMakeTupleKontEnv *env) { }) } */ -static LamExp *cpsTcLamApply(LamApply *node, LamExp *c) { - ENTER(cpsTcLamApply); +static MinExp *cpsTcMinApply(MinApply *node, MinExp *c) { + ENTER(cpsTcMinApply); if (node == NULL) { - LEAVE(cpsTcLamApply); + LEAVE(cpsTcMinApply); return NULL; } CpsKont *kont1 = makeKont_TcApply1(node->args, c); int save = PROTECT(kont1); - LamExp *result = cpsTk(node->function, kont1); + MinExp *result = cpsTk(node->function, kont1); UNPROTECT(save); - LEAVE(cpsTcLamApply); + LEAVE(cpsTcMinApply); return result; } -LamExp *TcApply1Kont(LamExp *sf, TcApply1KontEnv *env) { +MinExp *TcApply1Kont(MinExp *sf, TcApply1KontEnv *env) { ENTER(T_c_apply_1Kont); CpsKont *kont2 = makeKont_TcApply2(sf, env->c); int save = PROTECT(kont2); - LamExp *args = newLamExp_Args(CPI(env->c), env->es); + MinExp *args = newMinExp_Args(CPI(env->c), env->es); PROTECT(args); - LamExp *result = cpsTs_k(args, kont2); + MinExp *result = cpsTs_k(args, kont2); UNPROTECT(save); LEAVE(T_c_apply_1Kont); return result; } -LamExp *TcApply2Kont(LamExp *ses, TcApply2KontEnv *env) { +MinExp *TcApply2Kont(MinExp *ses, TcApply2KontEnv *env) { ENTER(TcApply2Kont); - LamArgs *args = appendLamArg(getLamExp_Args(ses), env->c); + MinExprList *args = appendMinArg(getMinExp_Args(ses), env->c); int save = PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(env->sf), env->sf, args); + MinExp *result = makeMinExp_Apply(CPI(env->sf), env->sf, args); UNPROTECT(save); LEAVE(TcApply2Kont); return result; @@ -284,102 +215,13 @@ LamExp *TcApply2Kont(LamExp *ses, TcApply2KontEnv *env) { E.lookUp(name, index, T_c(expr, c)) } */ -static LamExp *cpsTcLamLookUp(LamLookUp *node, LamExp *c) { - ENTER(cpsTcLamLookUp); - LamExp *expr = cpsTcLamExp(node->exp, c); +static MinExp *cpsTcMinLookUp(MinLookUp *node, MinExp *c) { + ENTER(cpsTcMinLookUp); + MinExp *expr = cpsTcMinExp(node->exp, c); int save = PROTECT(expr); - LamExp *result = makeLamExp_LookUp(CPI(node), node->nsId, node->nsSymbol, expr); - UNPROTECT(save); - LEAVE(cpsTcLamLookUp); - return result; -} - -/* - (E.construct(name, tag, args)) { - Ts_k(args, fn (sargs) { - E.apply(c, [E.construct(name, tag, sargs)]) - }) - } -*/ -static LamExp *cpsTcLamConstruct(LamConstruct *node, LamExp *c) { - ENTER(cpsTcLamConstruct); - LamExp *args = newLamExp_Args(CPI(node), node->args); - int save = PROTECT(args); - CpsKont *kont = makeKont_TcConstruct(node->name, node->tag, c); - PROTECT(kont); - LamExp *result = cpsTs_k(args, kont); - UNPROTECT(save); - LEAVE(cpsTcLamConstruct); - return result; -} - -LamExp *TcConstructKont(LamExp *sargs, TcConstructKontEnv *env) { - ENTER(TcConstructKont); - LamExp *construct = makeLamExp_Construct(CPI(sargs), env->name, env->tag, getLamExp_Args(sargs)); - int save = PROTECT(construct); - LamArgs *args = newLamArgs(CPI(sargs), construct, NULL); - PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(sargs), env->c, args); - UNPROTECT(save); - LEAVE(TcConstructKont); - return result; -} - -/* - (E.deconstruct(name, nsId, vec, expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.deconstruct(name, nsId, vec, sexpr)]) - }) - } -*/ -static LamExp *cpsTcLamDeconstruct(LamDeconstruct *node, LamExp *c) { - ENTER(cpsTcLamDeconstruct); - CpsKont *kont = makeKont_TcDeconstruct(node->name, node->nsId, node->vec, c); - int save = PROTECT(kont); - LamExp *result = cpsTk(node->exp, kont); - UNPROTECT(save); - LEAVE(cpsTcLamDeconstruct); - return result; -} - -LamExp *TcDeconstructKont(LamExp *sexpr, TcDeconstructKontEnv *env) { - ENTER(TcDeconstructKont); - LamExp *deconstruct = makeLamExp_Deconstruct(CPI(sexpr), env->name, env->nsId, env->vec, sexpr); - int save = PROTECT(deconstruct); - LamArgs *args = newLamArgs(CPI(sexpr), deconstruct, NULL); - PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(sexpr), env->c, args); - UNPROTECT(save); - LEAVE(TcDeconstructKont); - return result; -} - -/* - (E.tuple_index(size, index, expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.tuple_index(size, index, sexpr)]) - }) - } -*/ -static LamExp *cpsTcLamTupleIndex(LamTupleIndex *node, LamExp *c) { - ENTER(cpsTcLamTupleIndex); - CpsKont *kont = makeKont_TcTupleIndex(node->size, node->vec, c); - int save = PROTECT(kont); - LamExp *result = cpsTk(node->exp, kont); + MinExp *result = makeMinExp_LookUp(CPI(node), node->nsId, expr); UNPROTECT(save); - LEAVE(cpsTcLamTupleIndex); - return result; -} - -LamExp *TcTupleIndexKont(LamExp *sexpr, TcTupleIndexKontEnv *env) { - ENTER(TcTupleIndexKont); - LamExp *tuple_index = makeLamExp_TupleIndex(CPI(sexpr), env->size, env->index, sexpr); - int save = PROTECT(tuple_index); - LamArgs *args = newLamArgs(CPI(sexpr), tuple_index, NULL); - PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(sexpr), env->c, args); - UNPROTECT(save); - LEAVE(TcTupleIndexKont); + LEAVE(cpsTcMinLookUp); return result; } @@ -390,25 +232,25 @@ LamExp *TcTupleIndexKont(LamExp *sexpr, TcTupleIndexKontEnv *env) { }) } */ -static LamExp *cpsTcMakeVec(LamMakeVec *node, LamExp *c) { +static MinExp *cpsTcMakeVec(MinExprList *node, MinExp *c) { ENTER(cpsTcMakeVec); - CpsKont *kont = makeKont_TcMakeVec(node->nArgs, c); + CpsKont *kont = makeKont_TcMakeVec(c); int save = PROTECT(kont); - LamExp *args = newLamExp_Args(CPI(node), node->args); + MinExp *args = newMinExp_Args(CPI(node), node); PROTECT(args); - LamExp *result = cpsTs_k(args, kont); + MinExp *result = cpsTs_k(args, kont); UNPROTECT(save); LEAVE(cpsTcMakeVec); return result; } -LamExp *TcMakeVecKont(LamExp *sargs, TcMakeVecKontEnv *env) { +MinExp *TcMakeVecKont(MinExp *sargs, TcMakeVecKontEnv *env) { ENTER(TcMakeVecKont); - LamExp *make_vec = makeLamExp_MakeVec(CPI(sargs), env->size, getLamExp_Args(sargs)); + MinExp *make_vec = newMinExp_MakeVec(CPI(sargs), getMinExp_Args(sargs)); int save = PROTECT(make_vec); - LamArgs *args = newLamArgs(CPI(sargs), make_vec, NULL); + MinExprList *args = newMinExprList(CPI(sargs), make_vec, NULL); PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(sargs), env->c, args); + MinExp *result = makeMinExp_Apply(CPI(sargs), env->c, args); UNPROTECT(save); LEAVE(TcMakeVecKont); return result; @@ -425,56 +267,60 @@ LamExp *TcMakeVecKont(LamExp *sargs, TcMakeVecKontEnv *env) { })), [c]) } */ -static LamExp *cpsTcLamIff(LamIff *node, LamExp *c) { - ENTER(cpsTcLamIff); - LamExp *sk = makeVar(CPI(node), "k"); +static MinExp *cpsTcMinIff(MinIff *node, MinExp *c) { + ENTER(cpsTcMinIff); + MinExp *sk = makeVar(CPI(node), "k"); int save = PROTECT(sk); CpsKont *k = makeKont_TcIff(sk, node->consequent, node->alternative); PROTECT(k); - LamExp *body = cpsTk(node->condition, k); + MinExp *body = cpsTk(node->condition, k); PROTECT(body); - LamVarList *args = newLamVarList(CPI(node), getLamExp_Var(sk), NULL); + SymbolList *args = newSymbolList(CPI(node), getMinExp_Var(sk), NULL); PROTECT(args); - LamExp *lambda = makeLamExp_Lam(CPI(node), args, body); + MinExp *lambda = makeMinExp_Lam(CPI(node), args, body); PROTECT(lambda); - LamArgs *arglist = newLamArgs(CPI(node), c, NULL); + MinExprList *arglist = newMinExprList(CPI(node), c, NULL); PROTECT(arglist); - LamExp *result = makeLamExp_Apply(CPI(node), lambda, arglist); + MinExp *result = makeMinExp_Apply(CPI(node), lambda, arglist); UNPROTECT(save); - LEAVE(cpsTcLamIff); + LEAVE(cpsTcMinIff); return result; } -LamExp *TcIffKont(LamExp *aexp, TcIffKontEnv *env) { +MinExp *TcIffKont(MinExp *aexp, TcIffKontEnv *env) { ENTER(TcIffKont); - LamExp *then_exp = cpsTc(env->exprt, env->sk); + MinExp *then_exp = cpsTc(env->exprt, env->sk); int save = PROTECT(then_exp); - LamExp *else_exp = cpsTc(env->exprf, env->sk); + MinExp *else_exp = cpsTc(env->exprf, env->sk); PROTECT(else_exp); - LamExp *result = makeLamExp_Iff(CPI(aexp), aexp, then_exp, else_exp); + MinExp *result = makeMinExp_Iff(CPI(aexp), aexp, then_exp, else_exp); UNPROTECT(save); LEAVE(TcIffKont); return result; } -static LamIntCondCases *mapIntCondCases(LamIntCondCases *cases, LamExp *c) { - if (cases == NULL) return NULL; - LamIntCondCases *next = mapIntCondCases(cases->next, c); +static MinIntCondCases *mapIntCondCases(MinIntCondCases *cases, MinExp *c) { + if (cases == NULL) + return NULL; + MinIntCondCases *next = mapIntCondCases(cases->next, c); int save = PROTECT(next); - LamExp *body = cpsTc(cases->body, c); + MinExp *body = cpsTc(cases->body, c); PROTECT(body); - LamIntCondCases *result = newLamIntCondCases(CPI(cases), cases->constant, body, next); + MinIntCondCases *result = + newMinIntCondCases(CPI(cases), cases->constant, body, next); UNPROTECT(save); return result; } -static LamCharCondCases *mapCharCondCases(LamCharCondCases *cases, LamExp *c) { - if (cases == NULL) return NULL; - LamCharCondCases *next = mapCharCondCases(cases->next, c); +static MinCharCondCases *mapCharCondCases(MinCharCondCases *cases, MinExp *c) { + if (cases == NULL) + return NULL; + MinCharCondCases *next = mapCharCondCases(cases->next, c); int save = PROTECT(next); - LamExp *body = cpsTc(cases->body, c); + MinExp *body = cpsTc(cases->body, c); PROTECT(body); - LamCharCondCases *result = newLamCharCondCases(CPI(cases), cases->constant, body, next); + MinCharCondCases *result = + newMinCharCondCases(CPI(cases), cases->constant, body, next); UNPROTECT(save); return result; } @@ -491,48 +337,48 @@ static LamCharCondCases *mapCharCondCases(LamCharCondCases *cases, LamExp *c) { })), [c]) } */ -static LamExp *cpsTcLamCond(LamCond *node, LamExp *c) { - ENTER(cpsTcLamCond); - LamExp *sk = makeVar(CPI(node), "k"); +static MinExp *cpsTcMinCond(MinCond *node, MinExp *c) { + ENTER(cpsTcMinCond); + MinExp *sk = makeVar(CPI(node), "k"); int save = PROTECT(sk); CpsKont *k = makeKont_TcCond(sk, node->cases); PROTECT(k); - LamVarList *args = newLamVarList(CPI(node), getLamExp_Var(sk), NULL); + SymbolList *args = newSymbolList(CPI(node), getMinExp_Var(sk), NULL); PROTECT(args); - LamExp *body = cpsTk(node->value, k); + MinExp *body = cpsTk(node->value, k); PROTECT(body); - LamExp *lambda = makeLamExp_Lam(CPI(node), args, body); + MinExp *lambda = makeMinExp_Lam(CPI(node), args, body); PROTECT(lambda); - LamArgs *arglist = newLamArgs(CPI(node), c, NULL); + MinExprList *arglist = newMinExprList(CPI(node), c, NULL); PROTECT(arglist); - LamExp *result = makeLamExp_Apply(CPI(node), lambda, arglist); + MinExp *result = makeMinExp_Apply(CPI(node), lambda, arglist); UNPROTECT(save); - LEAVE(cpsTcLamCond); + LEAVE(cpsTcMinCond); return result; } -LamExp *TcCondKont(LamExp *atest, TcCondKontEnv *env) { +MinExp *TcCondKont(MinExp *atest, TcCondKontEnv *env) { ENTER(TcCondKont); - LamExp *result = NULL; - LamCondCases *cases = NULL; + MinExp *result = NULL; + MinCondCases *cases = NULL; int save = PROTECT(NULL); switch (env->branches->type) { - case LAMCONDCASES_TYPE_INTEGERS: { - LamIntCondCases *int_cases = mapIntCondCases(getLamCondCases_Integers(env->branches), env->sk); - PROTECT(int_cases); - cases = newLamCondCases_Integers(CPI(env->branches), int_cases); - PROTECT(cases); - } - break; - case LAMCONDCASES_TYPE_CHARACTERS: { - LamCharCondCases *char_cases = mapCharCondCases(getLamCondCases_Characters(env->branches), env->sk); - PROTECT(char_cases); - cases = newLamCondCases_Characters(CPI(env->branches), char_cases); - PROTECT(cases); - } - break; - } - result = makeLamExp_Cond(CPI(env->branches), atest, cases); + case MINCONDCASES_TYPE_INTEGERS: { + MinIntCondCases *int_cases = + mapIntCondCases(getMinCondCases_Integers(env->branches), env->sk); + PROTECT(int_cases); + cases = newMinCondCases_Integers(CPI(env->branches), int_cases); + PROTECT(cases); + } break; + case MINCONDCASES_TYPE_CHARACTERS: { + MinCharCondCases *char_cases = mapCharCondCases( + getMinCondCases_Characters(env->branches), env->sk); + PROTECT(char_cases); + cases = newMinCondCases_Characters(CPI(env->branches), char_cases); + PROTECT(cases); + } break; + } + result = makeMinExp_Cond(CPI(env->branches), atest, cases); UNPROTECT(save); LEAVE(TcCondKont); return result; @@ -550,84 +396,37 @@ LamExp *TcCondKont(LamExp *atest, TcCondKontEnv *env) { })), [c]) } */ -static LamExp *cpsTcLamMatch(LamMatch *node, LamExp *c) { - ENTER(cpsTcLamMatch); - LamExp *sk = makeVar(CPI(node), "k"); +static MinExp *cpsTcMinMatch(MinMatch *node, MinExp *c) { + ENTER(cpsTcMinMatch); + MinExp *sk = makeVar(CPI(node), "k"); int save = PROTECT(sk); CpsKont *k = makeKont_TcMatch(sk, node->cases); PROTECT(k); - LamVarList *args = newLamVarList(CPI(node), getLamExp_Var(sk), NULL); + SymbolList *args = newSymbolList(CPI(node), getMinExp_Var(sk), NULL); PROTECT(args); - LamExp *body = cpsTk(node->index, k); + MinExp *body = cpsTk(node->index, k); PROTECT(body); - LamExp *lambda = makeLamExp_Lam(CPI(node), args, body); + MinExp *lambda = makeMinExp_Lam(CPI(node), args, body); PROTECT(lambda); - LamArgs *arglist = newLamArgs(CPI(node), c, NULL); + MinExprList *arglist = newMinExprList(CPI(node), c, NULL); PROTECT(arglist); - LamExp *result = makeLamExp_Apply(CPI(node), lambda, arglist); + MinExp *result = makeMinExp_Apply(CPI(node), lambda, arglist); UNPROTECT(save); - LEAVE(cpsTcLamMatch); + LEAVE(cpsTcMinMatch); return result; } -LamExp *TcMatchKont(LamExp *atest, TcMatchKontEnv *env) { +MinExp *TcMatchKont(MinExp *atest, TcMatchKontEnv *env) { ENTER(TcMatchKont); - LamMatchList *cases = mapTcOverMatchCases(env->cases, env->sk); + MinMatchList *cases = mapTcOverMatchCases(env->cases, env->sk); int save = PROTECT(cases); PROTECT(cases); - LamExp *result = makeLamExp_Match(CPI(env->cases), atest, cases); + MinExp *result = makeMinExp_Match(CPI(env->cases), atest, cases); UNPROTECT(save); LEAVE(TcMatchKont); return result; } -/* - (E.let_expr(bindings, expr)) { - let - #(vars, exps) = list.unzip(bindings); - in - T_c(E.apply(E.lambda(vars, expr), exps), c) - } -*/ -static LamExp *cpsTcLamLet(LamLet *node, LamExp *c) { - ENTER(cpsTcLamLet); - int save = PROTECT(NULL); - LamVarList *vars = NULL; - LamArgs *exps = NULL; - cpsUnzipLamBindings(node->bindings, &vars, &exps); // PROTECTED - LamExp *lambda = makeLamExp_Lam(CPI(node), vars, node->body); - PROTECT(lambda); - LamExp *apply = makeLamExp_Apply(CPI(node), lambda, exps); - PROTECT(apply); - LamExp *result = cpsTc(apply, c); - UNPROTECT(save); - LEAVE(cpsTcLamLet); - return result; -} - -/* - (E.letstar_expr(bindings, expr)) { - let - fn nest_lets { - ([], body) { body } - (#(var, exp) @ rest, body) { - E.let_expr([#(var, exp)], nest_lets(rest, body)) - } - } - in - T_c(nest_lets(bindings, expr), c) - } -*/ -static LamExp *cpsTcLamLetStar(LamLetStar *node, LamExp *c) { - ENTER(cpsTcLamLetStar); - LamExp *lets = cpsNestLets(node->bindings, node->body); - int save = PROTECT(lets); - LamExp *result = cpsTc(lets, c); - UNPROTECT(save); - LEAVE(cpsTcLamLetStar); - return result; -} - /* (E.letrec_expr(bindings, expr)) { let @@ -636,15 +435,15 @@ static LamExp *cpsTcLamLetStar(LamLetStar *node, LamExp *c) { E.letrec_expr(list.zip(vars, list.map(M, aexps)), T_c(expr, c)) } */ -static LamExp *cpsTcLamLetRec(LamLetRec *node, LamExp *c) { - ENTER(cpsTcLamLetRec); - LamBindings *bindings = mapMOverBindings(node->bindings); +static MinExp *cpsTcMinLetRec(MinLetRec *node, MinExp *c) { + ENTER(cpsTcMinLetRec); + MinBindings *bindings = mapMOverBindings(node->bindings); int save = PROTECT(bindings); - LamExp *body = cpsTc(node->body, c); + MinExp *body = cpsTc(node->body, c); PROTECT(body); - LamExp *result = makeLamExp_LetRec(CPI(node), bindings, body); + MinExp *result = makeMinExp_LetRec(CPI(node), bindings, body); UNPROTECT(save); - LEAVE(cpsTcLamLetRec); + LEAVE(cpsTcMinLetRec); return result; } @@ -652,107 +451,35 @@ static LamExp *cpsTcLamLetRec(LamLetRec *node, LamExp *c) { (E.amb_expr(expr1, expr2)) { let k = gensym("$k"); - in - E.apply(E.lambda([k], E.amb_expr(T_c(expr1, k), T_c(expr2, k))), [c]) + in + E.apply(E.lambda([k], E.amb_expr(T_c(expr1, k), T_c(expr2, k))), + [c]) } */ -static LamExp *cpsTcLamAmb(LamAmb *node, LamExp *c) { - ENTER(cpsTcLamAmb); +static MinExp *cpsTcMinAmb(MinAmb *node, MinExp *c) { + ENTER(cpsTcMinAmb); if (node == NULL) { - LEAVE(cpsTcLamAmb); + LEAVE(cpsTcMinAmb); return NULL; } - LamExp *k = makeVar(CPI(node), "k"); + MinExp *k = makeVar(CPI(node), "k"); int save = PROTECT(k); - LamExp *e1 = cpsTc(node->left, k); + MinExp *e1 = cpsTc(node->left, k); PROTECT(e1); - LamExp *e2 = cpsTc(node->right, k); + MinExp *e2 = cpsTc(node->right, k); PROTECT(e2); - LamExp *lamAmb = makeLamExp_Amb(CPI(node), e1, e2); + MinExp *lamAmb = makeMinExp_Amb(CPI(node), e1, e2); PROTECT(lamAmb); - LamVarList *fargs = newLamVarList(CPI(node), getLamExp_Var(k), NULL); + SymbolList *fargs = newSymbolList(CPI(node), getMinExp_Var(k), NULL); PROTECT(fargs); - LamExp *lambda = makeLamExp_Lam(CPI(node), fargs, lamAmb); + MinExp *lambda = makeMinExp_Lam(CPI(node), fargs, lamAmb); PROTECT(lambda); - LamArgs *aargs = newLamArgs(CPI(node), c, NULL); + MinExprList *aargs = newMinExprList(CPI(node), c, NULL); PROTECT(aargs); - LamExp *result = makeLamExp_Apply(CPI(node), lambda, aargs); - LEAVE(cpsTcLamAmb); - UNPROTECT(save); - return result; -} - -/* - (E.print_exp(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.print_exp(sexpr)]) - }) - } -*/ -static LamExp *cpsTcLamPrint(LamPrint *node, LamExp *c) { - ENTER(cpsTcLamPrint); - CpsKont *kont = makeKont_TcPrint(c); - int save = PROTECT(kont); - LamExp *result = cpsTk(node->exp, kont); + MinExp *result = makeMinExp_Apply(CPI(node), lambda, aargs); + LEAVE(cpsTcMinAmb); UNPROTECT(save); - LEAVE(cpsTcLamPrint); - return result; -} - -LamExp *TcPrintKont(LamExp *sexpr, TcPrintKontEnv *env) { - ENTER(TcPrintKont); - LamExp *print_exp = makeLamExp_Print(CPI(sexpr), sexpr); - int save = PROTECT(print_exp); - LamArgs *args = newLamArgs(CPI(sexpr), print_exp, NULL); - PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(sexpr), env->c, args); - UNPROTECT(save); - LEAVE(TcPrintKont); - return result; -} - -/* - (E.typeOf_expr(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.typeOf_expr(sexpr)]) - }) - } -*/ -static LamExp *cpsTcLamTypeOf(LamTypeOf *node, LamExp *c) { - ENTER(cpsTcLamTypeOf); - CpsKont *k = makeKont_TcTypeOf(c); - int save = PROTECT(k); - LamExp *result = cpsTk(node->exp, k); - UNPROTECT(save); - LEAVE(cpsTcLamTypeOf); - return result; -} - -LamExp *TcTypeOfKont(LamExp *sexpr, TcTypeOfKontEnv *env) { - ENTER(TcTypeOfKont); - LamExp *typeOf_exp = makeLamExp_TypeOf(CPI(sexpr), sexpr); - int save = PROTECT(typeOf_exp); - LamArgs *args = newLamArgs(CPI(sexpr), typeOf_exp, NULL); - PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(sexpr), env->c, args); - UNPROTECT(save); - LEAVE(TcTypeOfKont); - return result; -} - -/* - (E.typeDefs(defs, expr)) { - E.typeDefs(defs, T_c(expr, c)) - } -*/ -static LamExp *cpsTcLamTypeDefs(LamTypeDefs *node, LamExp *c) { - ENTER(cpsTcLamTypeDefs); - LamExp *body = cpsTcLamExp(node->body, c); - int save = PROTECT(body); - LamExp *result = makeLamExp_TypeDefs(CPI(node), node->typeDefs, body); - UNPROTECT(save); - LEAVE(cpsTcLamTypeDefs); return result; } @@ -761,36 +488,37 @@ static LamExp *cpsTcLamTypeDefs(LamTypeDefs *node, LamExp *c) { (f (lambda (x i) (cc x)) cc)) */ -static LamExp *makeCallCC(ParserInfo PI) { - LamExp *f = makeVar(PI, "f"); +static MinExp *makeCallCC(ParserInfo PI) { + MinExp *f = makeVar(PI, "f"); int save = PROTECT(f); - LamExp *cc = makeVar(PI, "cc"); + MinExp *cc = makeVar(PI, "cc"); PROTECT(cc); - LamExp *x = makeVar(PI, "x"); + MinExp *x = makeVar(PI, "x"); PROTECT(x); - LamExp *i = makeVar(PI, "i"); + MinExp *i = makeVar(PI, "i"); PROTECT(i); - LamArgs *args = newLamArgs(PI, x, NULL); // (x) + MinExprList *args = newMinExprList(PI, x, NULL); // (x) PROTECT(args); - LamExp *apply = makeLamExp_Apply(PI, cc, args); // (cc x) + MinExp *apply = makeMinExp_Apply(PI, cc, args); // (cc x) PROTECT(apply); - LamVarList *vars = newLamVarList(PI, getLamExp_Var(i), NULL); // (i) + SymbolList *vars = newSymbolList(PI, getMinExp_Var(i), NULL); // (i) PROTECT(vars); - vars = newLamVarList(PI, getLamExp_Var(x), vars); // (x i) + vars = newSymbolList(PI, getMinExp_Var(x), vars); // (x i) PROTECT(vars); - LamExp *lambda = makeLamExp_Lam(PI, vars, apply); // (lambda (x i) (cc x)) + MinExp *lambda = makeMinExp_Lam(PI, vars, apply); // (lambda (x i) (cc x)) PROTECT(lambda); - args = newLamArgs(PI, lambda, NULL); // ((lambda (x i) (cc x))) + args = newMinExprList(PI, lambda, NULL); // ((lambda (x i) (cc x))) PROTECT(args); - args = newLamArgs(PI, cc, args); // ((lambda (x i) (cc x)) cc) + args = newMinExprList(PI, cc, args); // ((lambda (x i) (cc x)) cc) PROTECT(args); - apply = makeLamExp_Apply(PI, f, args); // (f (lambda (x i) (cc x)) cc) + apply = makeMinExp_Apply(PI, f, args); // (f (lambda (x i) (cc x)) cc) PROTECT(apply); - vars = newLamVarList(PI, getLamExp_Var(cc), NULL); // (cc) + vars = newSymbolList(PI, getMinExp_Var(cc), NULL); // (cc) PROTECT(vars); - vars = newLamVarList(PI, getLamExp_Var(f), vars); // (f cc) + vars = newSymbolList(PI, getMinExp_Var(f), vars); // (f cc) PROTECT(vars); - lambda = makeLamExp_Lam(PI, vars, apply); // (lambda (f cc) (f (lambda (x i) (cc x)) cc)) + lambda = makeMinExp_Lam( + PI, vars, apply); // (lambda (f cc) (f (lambda (x i) (cc x)) cc)) UNPROTECT(save); return lambda; } @@ -805,90 +533,71 @@ static LamExp *makeCallCC(ParserInfo PI) { }) } */ -static LamExp *cpsTcCallCC(LamExp *e, LamExp *c) { +static MinExp *cpsTcCallCC(MinExp *e, MinExp *c) { ENTER(cpsTcCallCC); CpsKont *k = makeKont_TcCallCC(c); int save = PROTECT(k); - LamExp *result = cpsTk(e, k); + MinExp *result = cpsTk(e, k); UNPROTECT(save); LEAVE(cpsTcCallCC); return result; } -LamExp *TcCallCCKont(LamExp *sf, TcCallCCKontEnv *env) { +MinExp *TcCallCCKont(MinExp *sf, TcCallCCKontEnv *env) { ENTER(TcCallCCKont); - LamExp *callCC = makeCallCC(CPI(sf)); + MinExp *callCC = makeCallCC(CPI(sf)); int save = PROTECT(callCC); - LamArgs * args = newLamArgs(CPI(env->c), env->c, NULL); + MinExprList *args = newMinExprList(CPI(env->c), env->c, NULL); PROTECT(args); - args = newLamArgs(CPI(env->c), sf, args); + args = newMinExprList(CPI(env->c), sf, args); PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(env->c), callCC, args); + MinExp *result = makeMinExp_Apply(CPI(env->c), callCC, args); UNPROTECT(save); LEAVE(TcCallCCKont); return result; } -static LamExp *cpsTcLamExp(LamExp *node, LamExp *c) { - if (node == NULL) return NULL; +static MinExp *cpsTcMinExp(MinExp *node, MinExp *c) { + if (node == NULL) + return NULL; if (isAexpr(node)) { - LamExp *exp = cpsM(node); + MinExp *exp = cpsM(node); int save = PROTECT(exp); - LamArgs *arglist = newLamArgs(CPI(node), exp, NULL); + MinExprList *arglist = newMinExprList(CPI(node), exp, NULL); PROTECT(arglist); - LamExp *result = makeLamExp_Apply(CPI(node), c, arglist); + MinExp *result = makeMinExp_Apply(CPI(node), c, arglist); UNPROTECT(save); return result; } switch (node->type) { - case LAMEXP_TYPE_AMB: - return cpsTcLamAmb(getLamExp_Amb(node), c); - case LAMEXP_TYPE_APPLY: - return cpsTcLamApply(getLamExp_Apply(node), c); - case LAMEXP_TYPE_CALLCC: - return cpsTcCallCC(getLamExp_CallCC(node), c); - case LAMEXP_TYPE_COND: - return cpsTcLamCond(getLamExp_Cond(node), c); - case LAMEXP_TYPE_CONSTRUCT: - return cpsTcLamConstruct(getLamExp_Construct(node), c); - case LAMEXP_TYPE_DECONSTRUCT: - return cpsTcLamDeconstruct(getLamExp_Deconstruct(node), c); - case LAMEXP_TYPE_IFF: - return cpsTcLamIff(getLamExp_Iff(node), c); - case LAMEXP_TYPE_LET: - return cpsTcLamLet(getLamExp_Let(node), c); - case LAMEXP_TYPE_LETSTAR: - return cpsTcLamLetStar(getLamExp_LetStar(node), c); - case LAMEXP_TYPE_LETREC: - return cpsTcLamLetRec(getLamExp_LetRec(node), c); - case LAMEXP_TYPE_LOOKUP: - return cpsTcLamLookUp(getLamExp_LookUp(node), c); - case LAMEXP_TYPE_MAKETUPLE: - return cpsTcMakeTuple(getLamExp_MakeTuple(node), c); - case LAMEXP_TYPE_MAKEVEC: - return cpsTcMakeVec(getLamExp_MakeVec(node), c); - case LAMEXP_TYPE_MATCH: - return cpsTcLamMatch(getLamExp_Match(node), c); - case LAMEXP_TYPE_NAMESPACES: - return cpsTcLamNameSpaceArray(getLamExp_NameSpaces(node), c); - case LAMEXP_TYPE_PRIM: - return cpsTcLamPrimApp(getLamExp_Prim(node), c); - case LAMEXP_TYPE_PRINT: - return cpsTcLamPrint(getLamExp_Print(node), c); - case LAMEXP_TYPE_SEQUENCE: - return cpsTcLamSequence(getLamExp_Sequence(node), c); - case LAMEXP_TYPE_TAG: - return cpsTcTag(getLamExp_Tag(node), c); - case LAMEXP_TYPE_TUPLEINDEX: - return cpsTcLamTupleIndex(getLamExp_TupleIndex(node), c); - case LAMEXP_TYPE_TYPEDEFS: - return cpsTcLamTypeDefs(getLamExp_TypeDefs(node), c); - case LAMEXP_TYPE_TYPEOF: - return cpsTcLamTypeOf(getLamExp_TypeOf(node), c); - default: - cant_happen("unrecognized LamExp type %s", lamExpTypeName(node->type)); + case MINEXP_TYPE_AMB: + return cpsTcMinAmb(getMinExp_Amb(node), c); + case MINEXP_TYPE_APPLY: + return cpsTcMinApply(getMinExp_Apply(node), c); + case MINEXP_TYPE_CALLCC: + return cpsTcCallCC(getMinExp_CallCC(node), c); + case MINEXP_TYPE_COND: + return cpsTcMinCond(getMinExp_Cond(node), c); + case MINEXP_TYPE_IFF: + return cpsTcMinIff(getMinExp_Iff(node), c); + case MINEXP_TYPE_LETREC: + return cpsTcMinLetRec(getMinExp_LetRec(node), c); + case MINEXP_TYPE_LOOKUP: + return cpsTcMinLookUp(getMinExp_LookUp(node), c); + case MINEXP_TYPE_MAKEVEC: + return cpsTcMakeVec(getMinExp_MakeVec(node), c); + case MINEXP_TYPE_MATCH: + return cpsTcMinMatch(getMinExp_Match(node), c); + case MINEXP_TYPE_NAMESPACES: + return cpsTcMinNameSpaceArray(getMinExp_NameSpaces(node), c); + case MINEXP_TYPE_PRIM: + return cpsTcMinPrimApp(getMinExp_Prim(node), c); + case MINEXP_TYPE_SEQUENCE: + return cpsTcMinSequence(getMinExp_Sequence(node), c); + default: + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } } @@ -899,35 +608,35 @@ static LamExp *cpsTcLamExp(LamExp *node, LamExp *c) { }) } */ -static LamExp *cpsTcLamNameSpaceArray(LamNameSpaceArray *node, LamExp *c) { - ENTER(cpsTcLamNameSpaceArray); - LamExp *seq = nsaToArgs(node); +static MinExp *cpsTcMinNameSpaceArray(MinNameSpaceArray *node, MinExp *c) { + ENTER(cpsTcMinNameSpaceArray); + MinExp *seq = nsaToArgs(node); int save = PROTECT(seq); CpsKont *k1 = makeKont_TcNameSpaces(c); PROTECT(k1); - LamExp *result = cpsTs_k(seq, k1); + MinExp *result = cpsTs_k(seq, k1); UNPROTECT(save); - LEAVE(cpsTcLamNameSpaceArray); + LEAVE(cpsTcMinNameSpaceArray); return result; } -LamExp *TcNameSpacesKont(LamExp *sexprs, TcNameSpacesKontEnv *env) { +MinExp *TcNameSpacesKont(MinExp *sexprs, TcNameSpacesKontEnv *env) { ENTER(TcNameSpacesKont); - LamNameSpaceArray *nsa = argsToNsa(sexprs); + MinNameSpaceArray *nsa = argsToNsa(sexprs); int save = PROTECT(nsa); - LamExp *nsaExp = newLamExp_NameSpaces(CPI(sexprs), nsa); + MinExp *nsaExp = newMinExp_NameSpaces(CPI(sexprs), nsa); PROTECT(nsaExp); - LamArgs *args = newLamArgs(CPI(nsaExp), nsaExp, NULL); + MinExprList *args = newMinExprList(CPI(nsaExp), nsaExp, NULL); PROTECT(args); - LamExp *result = makeLamExp_Apply(CPI(env->c), env->c, args); + MinExp *result = makeMinExp_Apply(CPI(env->c), env->c, args); UNPROTECT(save); LEAVE(TcNameSpacesKont); return result; } -LamExp *cpsTc(LamExp *node, LamExp *c) { +MinExp *cpsTc(MinExp *node, MinExp *c) { ENTER(cpsTc); - LamExp *result = cpsTcLamExp(node, c); + MinExp *result = cpsTcMinExp(node, c); LEAVE(cpsTc); return result; } \ No newline at end of file diff --git a/src/lambda_cpsTk.c b/src/lambda_cpsTk.c index e57c78da..d444f2b2 100644 --- a/src/lambda_cpsTk.c +++ b/src/lambda_cpsTk.c @@ -1,17 +1,17 @@ /* * CEKF - VM supporting amb * Copyright (C) 2022-2025 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 . * @@ -19,87 +19,77 @@ * Generated from src/lambda.yaml by tools/generate.py */ -#include "lambda.h" +#include "common.h" #include "memory.h" +#include "minlam.h" #include "symbol.h" -#include "common.h" -#include "lambda_cps.h" -#include "lambda_functions.h" #include "cps_kont.h" #include "cps_kont_impl.h" +#include "lambda_cps.h" +#include "lambda_functions.h" #ifdef DEBUG_LAMBDA_CPSTK -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif // Forward declarations -static LamExp *cpsTkLamPrimApp(LamPrimApp *node, CpsKont *k); -static LamExp *cpsTkLamSequence(LamSequence *node, CpsKont *k); -static LamExp *cpsTkMakeTuple(LamArgs *node, CpsKont *k); -static LamExp *cpsTkLamApply(LamExp *node, CpsKont *k); -static LamExp *cpsTkLamLookUp(LamLookUp *node, CpsKont *k); -static LamExp *cpsTkTag(LamExp *node, CpsKont *k); -static LamExp *cpsTkLamConstruct(LamConstruct *node, CpsKont *k); -static LamExp *cpsTkLamDeconstruct(LamDeconstruct *node, CpsKont *k); -static LamExp *cpsTkLamTupleIndex(LamTupleIndex *node, CpsKont *k); -static LamExp *cpsTkMakeVec(LamMakeVec *node, CpsKont *k); -static LamExp *cpsTkLamIff(LamIff *node, CpsKont *k); -static LamExp *cpsTkLamCond(LamCond *node, CpsKont *k); -static LamExp *cpsTkLamMatch(LamMatch *node, CpsKont *k); -static LamExp *cpsTkLamLet(LamLet *node, CpsKont *k); -static LamExp *cpsTkLamLetStar(LamLetStar *node, CpsKont *k); -static LamExp *cpsTkLamLetRec(LamLetRec *node, CpsKont *k); -static LamExp *cpsTkLamAmb(LamAmb *node, CpsKont *k); -static LamExp *cpsTkLamPrint(LamPrint *node, CpsKont *k); -static LamExp *cpsTkLamTypeOf(LamTypeOf *node, CpsKont *k); -static LamExp *cpsTkLamTypeDefs(LamTypeDefs *node, CpsKont *k); -static LamExp *cpsTkLamExp(LamExp *node, CpsKont *k); -static LamExp *cpsTkLamNameSpaceArray(LamNameSpaceArray *node, CpsKont *k); +static MinExp *cpsTkMinPrimApp(MinPrimApp *node, CpsKont *k); +static MinExp *cpsTkMinSequence(MinExprList *node, CpsKont *k); +static MinExp *cpsTkMinApply(MinExp *node, CpsKont *k); +static MinExp *cpsTkMinLookUp(MinLookUp *node, CpsKont *k); +static MinExp *cpsTkMakeVec(MinExprList *node, CpsKont *k); +static MinExp *cpsTkMinIff(MinIff *node, CpsKont *k); +static MinExp *cpsTkMinCond(MinCond *node, CpsKont *k); +static MinExp *cpsTkMinMatch(MinMatch *node, CpsKont *k); +static MinExp *cpsTkMinLetRec(MinLetRec *node, CpsKont *k); +static MinExp *cpsTkMinAmb(MinAmb *node, CpsKont *k); +static MinExp *cpsTkMinExp(MinExp *node, CpsKont *k); +static MinExp *cpsTkMinNameSpaceArray(MinNameSpaceArray *node, CpsKont *k); // utilities -static LamExp *INVOKE(CpsKont *k, LamExp *arg) { +static MinExp *INVOKE(CpsKont *k, MinExp *arg) { return k->wrapper(arg, k->env); } -bool isAexpr(LamExp *exp) { +bool isAexpr(MinExp *exp) { switch (exp->type) { - case LAMEXP_TYPE_VAR: - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_CHARACTER: - case LAMEXP_TYPE_CONSTANT: - case LAMEXP_TYPE_CONSTRUCTOR: - case LAMEXP_TYPE_ENV: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_LAM: - case LAMEXP_TYPE_STDINT: - case LAMEXP_TYPE_BIGINTEGER: - return true; - default: - return false; + case MINEXP_TYPE_VAR: + case MINEXP_TYPE_BACK: + case MINEXP_TYPE_CHARACTER: + case MINEXP_TYPE_ENV: + case MINEXP_TYPE_ERROR: + case MINEXP_TYPE_LAM: + case MINEXP_TYPE_STDINT: + case MINEXP_TYPE_BIGINTEGER: + return true; + default: + return false; } } -LamExp *makeVar(ParserInfo PI, char *prefix) { - return newLamExp_Var(PI, genSymDollar(prefix)); +MinExp *makeVar(ParserInfo PI, char *prefix) { + return newMinExp_Var(PI, genSymDollar(prefix)); } -LamArgs *appendLamArg(LamArgs *args, LamExp *exp) { - if (args == NULL) return newLamArgs(CPI(exp), exp, NULL); - LamArgs *next = appendLamArg(args->next, exp); +MinExprList *appendMinArg(MinExprList *args, MinExp *exp) { + if (args == NULL) + return newMinExprList(CPI(exp), exp, NULL); + MinExprList *next = appendMinArg(args->next, exp); int save = PROTECT(next); - LamArgs *this = newLamArgs(CPI(args), args->exp, next); + MinExprList *this = newMinExprList(CPI(args), args->exp, next); UNPROTECT(save); return this; } -LamVarList *appendLamVar(ParserInfo PI, LamVarList *args, HashSymbol *var) { - if (args == NULL) return newLamVarList(PI, var, NULL); - LamVarList *next = appendLamVar(PI, args->next, var); +SymbolList *appendMinVar(ParserInfo PI, SymbolList *args, HashSymbol *var) { + if (args == NULL) + return newSymbolList(PI, var, NULL); + SymbolList *next = appendMinVar(PI, args->next, var); int save = PROTECT(next); - LamVarList *this = newLamVarList(CPI(args), args->var, next); + SymbolList *this = newSymbolList(CPI(args), args->symbol, next); UNPROTECT(save); return this; } @@ -116,36 +106,37 @@ LamVarList *appendLamVar(ParserInfo PI, LamVarList *args, HashSymbol *var) { } } */ -LamExp *cpsTs_k(LamExp *exp, CpsKont *k) { +MinExp *cpsTs_k(MinExp *exp, CpsKont *k) { ENTER(cpsTs_k); - if (getLamExp_Args(exp) == NULL) { + if (getMinExp_Args(exp) == NULL) { return INVOKE(k, exp); } - CpsKont *k1 = makeKont_TkS1(getLamExp_Args(exp)->next, k); + CpsKont *k1 = makeKont_TkS1(getMinExp_Args(exp)->next, k); int save = PROTECT(k1); - LamExp *result = cpsTk(getLamExp_Args(exp)->exp, k1); // T_k(h, fn (hd) { ...k...t... }) + MinExp *result = + cpsTk(getMinExp_Args(exp)->exp, k1); // T_k(h, fn (hd) { ...k...t... }) LEAVE(cpsTs_k); UNPROTECT(save); return result; } -LamExp *TkS1Kont(LamExp *hd, TkS1KontEnv *env) { +MinExp *TkS1Kont(MinExp *hd, TkS1KontEnv *env) { ENTER(TkS1Kont); CpsKont *k2 = makeKont_TkS2(env->k, hd); int save = PROTECT(k2); - LamExp *args = newLamExp_Args(CPI(hd), env->t); + MinExp *args = newMinExp_Args(CPI(hd), env->t); PROTECT(args); - LamExp *result = cpsTs_k(args, k2); // Ts_k(t, fn (tl) { ...k...hd... }) + MinExp *result = cpsTs_k(args, k2); // Ts_k(t, fn (tl) { ...k...hd... }) LEAVE(TkS1Kont); UNPROTECT(save); return result; } -LamExp *TkS2Kont(LamExp *tl, TkS2KontEnv *env) { +MinExp *TkS2Kont(MinExp *tl, TkS2KontEnv *env) { ENTER(TkS2Kont); - LamExp *args = makeLamExp_Args(CPI(env->hd), env->hd, getLamExp_Args(tl)); + MinExp *args = makeMinExp_Args(CPI(env->hd), env->hd, getMinExp_Args(tl)); int save = PROTECT(args); - LamExp *result = INVOKE(env->k, args); + MinExp *result = INVOKE(env->k, args); UNPROTECT(save); LEAVE(TkS2Kont); return result; @@ -157,47 +148,20 @@ LamExp *TkS2Kont(LamExp *tl, TkS2KontEnv *env) { in E.lambda([rv], k(rv)) } */ -static LamExp *kToC(ParserInfo PI, CpsKont *k) { - LamExp *rv = makeVar(PI, "rv"); +static MinExp *kToC(ParserInfo PI, CpsKont *k) { + MinExp *rv = makeVar(PI, "rv"); int save = PROTECT(rv); - LamExp *body = INVOKE(k, rv); + MinExp *body = INVOKE(k, rv); PROTECT(body); - LamVarList *args = newLamVarList(PI, getLamExp_Var(rv), NULL); + SymbolList *args = newSymbolList(PI, getMinExp_Var(rv), NULL); PROTECT(args); - LamExp *cont = makeLamExp_Lam(PI, args, body); + MinExp *cont = makeMinExp_Lam(PI, args, body); UNPROTECT(save); return cont; } // Visitor implementations -/* - (E.tag(expr)) { - T_k(expr, fn (sexpr) { - k(E.tag(sexpr)) - }) - } -*/ -static LamExp *cpsTkTag(LamExp *node, CpsKont *k) { - ENTER(cpsTkTag); - CpsKont *k1 = makeKont_TkTag(k); - int save = PROTECT(k1); - LamExp *result = cpsTk(node, k1); - UNPROTECT(save); - LEAVE(cpsTkTag); - return result; -} - -LamExp *TkTagKont(LamExp *sexpr, TkTagKontEnv *env) { - ENTER(TkTagKont); - LamExp *tagged = newLamExp_Tag(CPI(sexpr), sexpr); - int save = PROTECT(tagged); - LamExp *result = INVOKE(env->k, tagged); - UNPROTECT(save); - LEAVE(TkTagKont); - return result; -} - /* (E.primapp(p, e1, e2)) { T_k(e1, fn (s1) { @@ -207,31 +171,31 @@ LamExp *TkTagKont(LamExp *sexpr, TkTagKontEnv *env) { }) } */ -static LamExp *cpsTkLamPrimApp(LamPrimApp *node, CpsKont *k) { - ENTER(cpsTkLamPrimApp); +static MinExp *cpsTkMinPrimApp(MinPrimApp *node, CpsKont *k) { + ENTER(cpsTkMinPrimApp); CpsKont *k1 = makeKont_TkPrimApp1(k, node->exp2, node->type); int save = PROTECT(k1); - LamExp *result = cpsTk(node->exp1, k1); + MinExp *result = cpsTk(node->exp1, k1); UNPROTECT(save); - LEAVE(cpsTkLamPrimApp); + LEAVE(cpsTkMinPrimApp); return result; } -LamExp *TkPrimApp1Kont(LamExp *s1, TkPrimApp1KontEnv *env) { +MinExp *TkPrimApp1Kont(MinExp *s1, TkPrimApp1KontEnv *env) { ENTER(TkPrimApp1Kont); CpsKont *k = makeKont_TkPrimApp2(env->k, s1, env->p); int save = PROTECT(k); - LamExp *result = cpsTk(env->e2, k); + MinExp *result = cpsTk(env->e2, k); UNPROTECT(save); LEAVE(TkPrimApp1Kont); return result; } -LamExp *TkPrimApp2Kont(LamExp *s2, TkPrimApp2KontEnv *env) { +MinExp *TkPrimApp2Kont(MinExp *s2, TkPrimApp2KontEnv *env) { ENTER(TkPrimApp2Kont); - LamExp *primapp = makeLamExp_Prim(CPI(env->s1), env->p, env->s1, s2); + MinExp *primapp = makeMinExp_Prim(CPI(env->s1), env->p, env->s1, s2); int save = PROTECT(primapp); - LamExp *result = INVOKE(env->k, primapp); + MinExp *result = INVOKE(env->k, primapp); UNPROTECT(save); LEAVE(TkPrimApp2Kont); return result; @@ -245,16 +209,16 @@ LamExp *TkPrimApp2Kont(LamExp *s2, TkPrimApp2KontEnv *env) { }) } */ -static LamExp *cpsTkLamSequence(LamSequence *node, CpsKont *k) { - ENTER(cpsTkLamSequence); +static MinExp *cpsTkMinSequence(MinExprList *node, CpsKont *k) { + ENTER(cpsTkMinSequence); #ifdef SAFETY_CHECKS if (node == NULL) { - cant_happen("NULL node in cpsTkLamSequence"); + cant_happen("NULL node in cpsTkMinSequence"); } #endif - LamExp *result = NULL; + MinExp *result = NULL; int save = PROTECT(NULL); - if(node->next == NULL) { + if (node->next == NULL) { result = cpsTk(node->exp, k); } else { CpsKont *k1 = makeKont_TkSequence(k, node->next); @@ -262,49 +226,20 @@ static LamExp *cpsTkLamSequence(LamSequence *node, CpsKont *k) { result = cpsTk(node->exp, k1); } UNPROTECT(save); - LEAVE(cpsTkLamSequence); + LEAVE(cpsTkMinSequence); return result; } -LamExp *TkSequenceKont(LamExp *ignored, TkSequenceKontEnv *env) { +MinExp *TkSequenceKont(MinExp *ignored, TkSequenceKontEnv *env) { ENTER(TkSequenceKont); - LamExp *sequence = newLamExp_Sequence(CPI(ignored), env->exprs); + MinExp *sequence = newMinExp_Sequence(CPI(ignored), env->exprs); int save = PROTECT(sequence); - LamExp *result = cpsTk(sequence, env->k); + MinExp *result = cpsTk(sequence, env->k); UNPROTECT(save); LEAVE(TkSequenceKont); return result; } -/* - (E.make_tuple(args)) { - Ts_k(args, fn (sargs) { - k(E.make_tuple(sargs)) - }) - } -*/ -static LamExp *cpsTkMakeTuple(LamArgs *node, CpsKont *k) { - ENTER(cpsTkMakeTuple); - CpsKont *k1 = makeKont_TkMakeTuple(k); - int save = PROTECT(k1); - LamExp *exp = newLamExp_Args(CPI(node), node); - PROTECT(exp); - LamExp *result = cpsTs_k(exp, k1); - UNPROTECT(save); - LEAVE(cpsTkMakeTuple); - return result; -} - -LamExp *TkMakeTupleKont(LamExp *sargs, TkMakeTupleKontEnv *env) { - ENTER(TkMakeTupleKont); - LamExp *make_tuple = newLamExp_MakeTuple(CPI(sargs), getLamExp_Args(sargs)); - int save = PROTECT(make_tuple); - LamExp *result = INVOKE(env->k, make_tuple); - UNPROTECT(save); - LEAVE(TkMakeTupleKont); - return result; -} - /* (E.apply(_, _)) { let @@ -313,18 +248,18 @@ LamExp *TkMakeTupleKont(LamExp *sargs, TkMakeTupleKontEnv *env) { T_c(e, c) } */ -static LamExp *cpsTkLamApply(LamExp *node, CpsKont *k) { - ENTER(cpsTkLamApply); +static MinExp *cpsTkMinApply(MinExp *node, CpsKont *k) { + ENTER(cpsTkMinApply); if (node == NULL) { - LEAVE(cpsTkLamApply); + LEAVE(cpsTkMinApply); return NULL; } - LamExp *c = kToC(CPI(node), k); + MinExp *c = kToC(CPI(node), k); int save = PROTECT(c); - LamExp *result = cpsTc(node, c); + MinExp *result = cpsTc(node, c); UNPROTECT(save); - LEAVE(cpsTkLamApply); + LEAVE(cpsTkMinApply); return result; } @@ -333,96 +268,13 @@ static LamExp *cpsTkLamApply(LamExp *node, CpsKont *k) { E.lookUp(name, index, T_k(expr, k)) } */ -static LamExp *cpsTkLamLookUp(LamLookUp *node, CpsKont *k) { - ENTER(cpsTkLamLookUp); - LamExp *expr = cpsTk(node->exp, k); +static MinExp *cpsTkMinLookUp(MinLookUp *node, CpsKont *k) { + ENTER(cpsTkMinLookUp); + MinExp *expr = cpsTk(node->exp, k); int save = PROTECT(expr); - LamExp *result = makeLamExp_LookUp(CPI(node), node->nsId, node->nsSymbol, expr); + MinExp *result = makeMinExp_LookUp(CPI(node), node->nsId, expr); UNPROTECT(save); - LEAVE(cpsTkLamLookUp); - return result; -} - -/* - (E.construct(name, args)) { - Ts_k(args, fn (sargs) { - k(E.construct(name, sargs)) - }) - } -*/ -static LamExp *cpsTkLamConstruct(LamConstruct *node, CpsKont *k) { - ENTER(cpsTkLamConstruct); - CpsKont *k1 = makeKont_TkConstruct(node->name, node->tag, k); - int save = PROTECT(k1); - LamExp *args = newLamExp_Args(CPI(node), node->args); - PROTECT(args); - LamExp *result = cpsTs_k(args, k1); - UNPROTECT(save); - LEAVE(cpsTkLamConstruct); - return result; -} - -LamExp *TkConstructKont(LamExp *sargs, TkConstructKontEnv *env) { - ENTER(TkConstructKont); - LamExp *construct = makeLamExp_Construct(CPI(sargs), env->name, env->tag, getLamExp_Args(sargs)); - int save = PROTECT(construct); - LamExp *result = INVOKE(env->k, construct); - UNPROTECT(save); - LEAVE(TkConstructKont); - return result; -} - -/* - (E.deconstruct(name, nsId, vec, expr)) { - T_k(expr, fn (sexpr) { - k(E.deconstruct(name, nsId, vec, sexpr)) - }) - } -*/ -static LamExp *cpsTkLamDeconstruct(LamDeconstruct *node, CpsKont *k) { - ENTER(cpsTkLamDeconstruct); - CpsKont *k1 = makeKont_TkDeconstruct(node->name, node->nsId, node->vec, k); - int save = PROTECT(k1); - LamExp *result = cpsTk(node->exp, k1); - UNPROTECT(save); - LEAVE(cpsTkLamDeconstruct); - return result; -} - -LamExp *TkDeconstructKont(LamExp *sexpr, TkDeconstructKontEnv *env) { - ENTER(TkDeconstructKont); - LamExp *deconstruct = makeLamExp_Deconstruct(CPI(sexpr), env->name, env->nsId, env->vec, sexpr); - int save = PROTECT(deconstruct); - LamExp *result = INVOKE(env->k, deconstruct); - UNPROTECT(save); - LEAVE(TkDeconstructKont); - return result; -} - -/* - (E.tuple_index(size, index, expr)) { - T_k(expr, fn (sexpr) { - k(E.tuple_index(size, index, sexpr)) - }) - } -*/ -static LamExp *cpsTkLamTupleIndex(LamTupleIndex *node, CpsKont *k) { - ENTER(cpsTkLamTupleIndex); - CpsKont *k1 = makeKont_TkTupleIndex(node->size, node->vec, k); - int save = PROTECT(k1); - LamExp *result = cpsTk(node->exp, k1); - UNPROTECT(save); - LEAVE(cpsTkLamTupleIndex); - return result; -} - -LamExp *TkTupleIndexKont(LamExp *sexpr, TkTupleIndexKontEnv *env) { - ENTER(TkTupleIndexKont); - LamExp *tuple_index = makeLamExp_TupleIndex(CPI(sexpr), env->size, env->index, sexpr); - int save = PROTECT(tuple_index); - LamExp *result = INVOKE(env->k, tuple_index); - UNPROTECT(save); - LEAVE(TkTupleIndexKont); + LEAVE(cpsTkMinLookUp); return result; } @@ -433,23 +285,23 @@ LamExp *TkTupleIndexKont(LamExp *sexpr, TkTupleIndexKontEnv *env) { }) } */ -static LamExp *cpsTkMakeVec(LamMakeVec *node, CpsKont *k) { +static MinExp *cpsTkMakeVec(MinExprList *node, CpsKont *k) { ENTER(cpsTkMakeVec); - CpsKont *k1 = makeKont_TkMakeVec(node->nArgs, k); + CpsKont *k1 = makeKont_TkMakeVec(k); int save = PROTECT(k1); - LamExp *args = newLamExp_Args(CPI(node), node->args); + MinExp *args = newMinExp_Args(CPI(node), node); PROTECT(args); - LamExp *result = cpsTs_k(args, k1); + MinExp *result = cpsTs_k(args, k1); UNPROTECT(save); LEAVE(cpsTkMakeVec); return result; } -LamExp *TkMakeVecKont(LamExp *sargs, TkMakeVecKontEnv *env) { +MinExp *TkMakeVecKont(MinExp *sargs, TkMakeVecKontEnv *env) { ENTER(TkMakeVecKont); - LamExp *make_vec = makeLamExp_MakeVec(CPI(sargs), env->size, getLamExp_Args(sargs)); + MinExp *make_vec = newMinExp_MakeVec(CPI(sargs), getMinExp_Args(sargs)); int save = PROTECT(make_vec); - LamExp *result = INVOKE(env->k, make_vec); + MinExp *result = INVOKE(env->k, make_vec); UNPROTECT(save); LEAVE(TkMakeVecKont); return result; @@ -459,58 +311,62 @@ LamExp *TkMakeVecKont(LamExp *sargs, TkMakeVecKontEnv *env) { (E.if_expr(exprc, exprt, exprf)) { let c = kToC(k); - in + in T_k(exprc, fn(aexp) { E.if_expr(aexp, T_c(exprt, c), T_c(exprf, c)) }) } */ -static LamExp *cpsTkLamIff(LamIff *node, CpsKont *k) { - ENTER(cpsTkLamIff); +static MinExp *cpsTkMinIff(MinIff *node, CpsKont *k) { + ENTER(cpsTkMinIff); if (node == NULL) { - LEAVE(cpsTkLamIff); + LEAVE(cpsTkMinIff); return NULL; } - LamExp *c = kToC(CPI(node), k); + MinExp *c = kToC(CPI(node), k); int save = PROTECT(c); CpsKont *k2 = makeKont_TkIff(c, node->consequent, node->alternative); PROTECT(k2); - LamExp *result = cpsTk(node->condition, k2); + MinExp *result = cpsTk(node->condition, k2); UNPROTECT(save); - LEAVE(cpsTkLamIff); + LEAVE(cpsTkMinIff); return result; } -LamExp *TkIffKont(LamExp *aexp, TkIffKontEnv *env) { +MinExp *TkIffKont(MinExp *aexp, TkIffKontEnv *env) { ENTER(TkIffKont); - LamExp *consequent = cpsTc(env->exprt, env->c); + MinExp *consequent = cpsTc(env->exprt, env->c); int save = PROTECT(consequent); - LamExp *alternative = cpsTc(env->exprf, env->c); + MinExp *alternative = cpsTc(env->exprf, env->c); PROTECT(alternative); - LamExp *result = makeLamExp_Iff(CPI(aexp), aexp, consequent, alternative); + MinExp *result = makeMinExp_Iff(CPI(aexp), aexp, consequent, alternative); UNPROTECT(save); LEAVE(TkIffKont); return result; } -static LamIntCondCases *mapIntCondCases(LamIntCondCases *cases, LamExp *c) { - if (cases == NULL) return NULL; - LamIntCondCases *next = mapIntCondCases(cases->next, c); +static MinIntCondCases *mapIntCondCases(MinIntCondCases *cases, MinExp *c) { + if (cases == NULL) + return NULL; + MinIntCondCases *next = mapIntCondCases(cases->next, c); int save = PROTECT(next); - LamExp *body = cpsTc(cases->body, c); + MinExp *body = cpsTc(cases->body, c); PROTECT(body); - LamIntCondCases *this = newLamIntCondCases(CPI(cases), cases->constant, body, next); + MinIntCondCases *this = + newMinIntCondCases(CPI(cases), cases->constant, body, next); UNPROTECT(save); return this; } -static LamCharCondCases *mapCharCondCases(LamCharCondCases *cases, LamExp *c) { - if (cases == NULL) return NULL; - LamCharCondCases *next = mapCharCondCases(cases->next, c); +static MinCharCondCases *mapCharCondCases(MinCharCondCases *cases, MinExp *c) { + if (cases == NULL) + return NULL; + MinCharCondCases *next = mapCharCondCases(cases->next, c); int save = PROTECT(next); - LamExp *body = cpsTc(cases->body, c); + MinExp *body = cpsTc(cases->body, c); PROTECT(body); - LamCharCondCases *this = newLamCharCondCases(CPI(cases), cases->constant, body, next); + MinCharCondCases *this = + newMinCharCondCases(CPI(cases), cases->constant, body, next); UNPROTECT(save); return this; } @@ -527,45 +383,46 @@ static LamCharCondCases *mapCharCondCases(LamCharCondCases *cases, LamExp *c) { }) } */ -static LamExp *cpsTkLamCond(LamCond *node, CpsKont *k) { - ENTER(cpsTkLamCond); +static MinExp *cpsTkMinCond(MinCond *node, CpsKont *k) { + ENTER(cpsTkMinCond); if (node == NULL) { - LEAVE(cpsTkLamCond); + LEAVE(cpsTkMinCond); return NULL; } - LamExp *c = kToC(CPI(node), k); + MinExp *c = kToC(CPI(node), k); int save = PROTECT(c); CpsKont *k2 = makeKont_TkCond(c, node->cases); PROTECT(k2); - LamExp *result = cpsTk(node->value, k2); + MinExp *result = cpsTk(node->value, k2); UNPROTECT(save); - LEAVE(cpsTkLamCond); + LEAVE(cpsTkMinCond); return result; } -LamExp *TkCondKont(LamExp *atest, TkCondKontEnv *env) { +MinExp *TkCondKont(MinExp *atest, TkCondKontEnv *env) { ENTER(TkCondKont); - LamCondCases *cases = NULL; + MinCondCases *cases = NULL; int save = PROTECT(NULL); switch (env->branches->type) { - case LAMCONDCASES_TYPE_INTEGERS: { - LamIntCondCases *int_cases = mapIntCondCases(getLamCondCases_Integers(env->branches), env->c); - PROTECT(int_cases); - cases = newLamCondCases_Integers(CPI(atest), int_cases); - PROTECT(cases); - } - break; - case LAMCONDCASES_TYPE_CHARACTERS: { - LamCharCondCases *char_cases = mapCharCondCases(getLamCondCases_Characters(env->branches), env->c); - PROTECT(char_cases); - cases = newLamCondCases_Characters(CPI(atest), char_cases); - PROTECT(cases); - } - break; - default: - cant_happen("Unknown LamCondCases type %s in TkCondKont", lamCondCasesTypeName(env->branches->type)); - } - LamExp *result = makeLamExp_Cond(CPI(atest), atest, cases); + case MINCONDCASES_TYPE_INTEGERS: { + MinIntCondCases *int_cases = + mapIntCondCases(getMinCondCases_Integers(env->branches), env->c); + PROTECT(int_cases); + cases = newMinCondCases_Integers(CPI(atest), int_cases); + PROTECT(cases); + } break; + case MINCONDCASES_TYPE_CHARACTERS: { + MinCharCondCases *char_cases = + mapCharCondCases(getMinCondCases_Characters(env->branches), env->c); + PROTECT(char_cases); + cases = newMinCondCases_Characters(CPI(atest), char_cases); + PROTECT(cases); + } break; + default: + cant_happen("Unknown MinCondCases type %s in TkCondKont", + minCondCasesTypeName(env->branches->type)); + } + MinExp *result = makeMinExp_Cond(CPI(atest), atest, cases); LEAVE(TkCondKont); UNPROTECT(save); return result; @@ -583,120 +440,80 @@ LamExp *TkCondKont(LamExp *atest, TkCondKontEnv *env) { }) } */ -static LamExp *cpsTkLamMatch(LamMatch *node, CpsKont *k) { - ENTER(cpsTkLamMatch); - LamExp *c = kToC(CPI(node), k); +static MinExp *cpsTkMinMatch(MinMatch *node, CpsKont *k) { + ENTER(cpsTkMinMatch); + MinExp *c = kToC(CPI(node), k); int save = PROTECT(c); CpsKont *k2 = makeKont_TkMatch(c, node->cases); PROTECT(k2); - LamExp *result = cpsTk(node->index, k2); + MinExp *result = cpsTk(node->index, k2); UNPROTECT(save); - LEAVE(cpsTkLamMatch); + LEAVE(cpsTkMinMatch); return result; } -LamMatchList *mapTcOverMatchCases(LamMatchList *cases, LamExp *c) { - if (cases == NULL) return NULL; - LamMatchList *next = mapTcOverMatchCases(cases->next, c); +MinMatchList *mapTcOverMatchCases(MinMatchList *cases, MinExp *c) { + if (cases == NULL) + return NULL; + MinMatchList *next = mapTcOverMatchCases(cases->next, c); int save = PROTECT(next); - LamExp *body = cpsTc(cases->body, c); + MinExp *body = cpsTc(cases->body, c); PROTECT(body); - LamMatchList *this = newLamMatchList(CPI(cases), cases->matches, body, next); + MinMatchList *this = + newMinMatchList(CPI(cases), cases->matches, body, next); UNPROTECT(save); return this; } -LamExp *TkMatchKont(LamExp *atest, TkMatchKontEnv *env) { +MinExp *TkMatchKont(MinExp *atest, TkMatchKontEnv *env) { ENTER(TkMatchKont); - LamMatchList *cases = mapTcOverMatchCases(env->cases, env->c); + MinMatchList *cases = mapTcOverMatchCases(env->cases, env->c); int save = PROTECT(cases); - LamExp *result = makeLamExp_Match(CPI(atest), atest, cases); + MinExp *result = makeMinExp_Match(CPI(atest), atest, cases); UNPROTECT(save); LEAVE(TkMatchKont); return result; } -void cpsUnzipLamBindings(LamBindings *bindings, - LamVarList **vars, - LamArgs **exps) { +void cpsUnzipMinBindings(MinBindings *bindings, SymbolList **vars, + MinExprList **exps) { if (bindings == NULL) { *vars = NULL; *exps = NULL; return; } - cpsUnzipLamBindings(bindings->next, vars, exps); - *vars = newLamVarList(CPI(bindings), bindings->var, *vars); + cpsUnzipMinBindings(bindings->next, vars, exps); + *vars = newSymbolList(CPI(bindings), bindings->var, *vars); PROTECT(*vars); - *exps = newLamArgs(CPI(bindings), bindings->val, *exps); + *exps = newMinExprList(CPI(bindings), bindings->val, *exps); PROTECT(*exps); } -/* - (E.let_expr(bindings, expr)) { - let - #(vars, exps) = list.unzip(bindings); - in - T_k(E.apply(E.lambda(vars, expr), exps), k) - } -*/ -static LamExp *cpsTkLamLet(LamLet *node, CpsKont *k) { - ENTER(cpsTkLamLet); - int save = PROTECT(NULL); - LamVarList *vars = NULL; - LamArgs *exps = NULL; - cpsUnzipLamBindings(node->bindings, &vars, &exps); // PROTECTED - LamExp *lambda = makeLamExp_Lam(CPI(node), vars, node->body); - PROTECT(lambda); - LamExp *apply = makeLamExp_Apply(CPI(node), lambda, exps); - PROTECT(apply); - LamExp *result = cpsTk(apply, k); - UNPROTECT(save); - LEAVE(cpsTkLamLet); - return result; -} - -LamExp *cpsNestLets(LamBindings *bindings, LamExp *body) { +MinExp *cpsNestLets(MinBindings *bindings, MinExp *body) { if (bindings == NULL) { return body; } - LamExp *rest = cpsNestLets(bindings->next, body); + MinExp *rest = cpsNestLets(bindings->next, body); int save = PROTECT(rest); - LamBindings *binding = newLamBindings(CPI(bindings), bindings->var, bindings->val, NULL); - PROTECT(binding); - LamExp *this = makeLamExp_Let(CPI(bindings), binding, rest); - UNPROTECT(save); - return this; -} -/* - (E.letstar_expr(bindings, expr)) { - let - fn nest_lets { - ([], body) { body } - (#(var, exp) @ rest, body) { - E.let_expr([#(var, exp)], nest_lets(rest, body)) - } - } - in - T_k(nest_lets(bindings, expr), k) - } -*/ -static LamExp *cpsTkLamLetStar(LamLetStar *node, CpsKont *k) { - ENTER(cpsTkLamLetStar); - LamExp *lets = cpsNestLets(node->bindings, node->body); - int save = PROTECT(lets); - LamExp *result = cpsTk(lets, k); + SymbolList *farg = newSymbolList(CPI(bindings), bindings->var, NULL); + PROTECT(farg); + MinExp *lambda = makeMinExp_Lam(CPI(bindings), farg, rest); + PROTECT(lambda); + MinExprList *aarg = newMinExprList(CPI(bindings), bindings->val, NULL); + PROTECT(aarg); + MinExp *apply = makeMinExp_Apply(CPI(bindings), lambda, aarg); UNPROTECT(save); - LEAVE(cpsTkLamLetStar); - return result; + return apply; } -LamBindings *mapMOverBindings(LamBindings *bindings) { - if (bindings == NULL) return NULL; - LamBindings *next = mapMOverBindings(bindings->next); +MinBindings *mapMOverBindings(MinBindings *bindings) { + if (bindings == NULL) + return NULL; + MinBindings *next = mapMOverBindings(bindings->next); int save = PROTECT(next); - LamExp *val = cpsM(bindings->val); + MinExp *val = cpsM(bindings->val); PROTECT(val); - LamBindings *this = newLamBindings(CPI(bindings), bindings->var, val, next); + MinBindings *this = newMinBindings(CPI(bindings), bindings->var, val, next); UNPROTECT(save); return this; } @@ -709,15 +526,15 @@ LamBindings *mapMOverBindings(LamBindings *bindings) { E.letrec_expr(list.zip(vars, list.map(M, aexps)), T_k(expr, k)) } */ -static LamExp *cpsTkLamLetRec(LamLetRec *node, CpsKont *k) { - ENTER(cpsTkLamLetRec); - LamBindings *bindings = mapMOverBindings(node->bindings); +static MinExp *cpsTkMinLetRec(MinLetRec *node, CpsKont *k) { + ENTER(cpsTkMinLetRec); + MinBindings *bindings = mapMOverBindings(node->bindings); int save = PROTECT(bindings); - LamExp *body = cpsTkLamExp(node->body, k); + MinExp *body = cpsTkMinExp(node->body, k); PROTECT(body); - LamExp *result = makeLamExp_LetRec(CPI(node), bindings, body); + MinExp *result = makeMinExp_LetRec(CPI(node), bindings, body); UNPROTECT(save); - LEAVE(cpsTkLamLetRec); + LEAVE(cpsTkMinLetRec); return result; } @@ -725,91 +542,22 @@ static LamExp *cpsTkLamLetRec(LamLetRec *node, CpsKont *k) { (E.amb_expr(expr1, expr2)) { let c = kToC(k); - in + in E.amb_expr(T_c(expr1, c), T_c(expr2, c)) } */ -static LamExp *cpsTkLamAmb(LamAmb *node, CpsKont *k) { - LamExp *c = kToC(CPI(node), k); +static MinExp *cpsTkMinAmb(MinAmb *node, CpsKont *k) { + MinExp *c = kToC(CPI(node), k); int save = PROTECT(c); - LamExp *exp1 = cpsTc(node->left, c); + MinExp *exp1 = cpsTc(node->left, c); PROTECT(exp1); - LamExp *exp2 = cpsTc(node->right, c); + MinExp *exp2 = cpsTc(node->right, c); PROTECT(exp2); - LamExp *result = makeLamExp_Amb(CPI(node), exp1, exp2); + MinExp *result = makeMinExp_Amb(CPI(node), exp1, exp2); UNPROTECT(save); return result; } -/* - (E.print_exp(expr)) { - T_k(expr, fn (sexpr) { - k(E.print_exp(sexpr)) - }) - } -*/ -static LamExp *cpsTkLamPrint(LamPrint *node, CpsKont *k) { - ENTER(cpsTkLamPrint); - CpsKont *k1 = makeKont_TkPrint(k); - int save = PROTECT(k1); - LamExp *result = cpsTk(node->exp, k1); - UNPROTECT(save); - LEAVE(cpsTkLamPrint); - return result; -} - -LamExp *TkPrintKont(LamExp *sexpr, TkPrintKontEnv *env) { - ENTER(TkPrintKont); - LamExp *print_exp = makeLamExp_Print(CPI(sexpr), sexpr); - int save = PROTECT(print_exp); - LamExp *result = INVOKE(env->k, print_exp); - UNPROTECT(save); - LEAVE(TkPrintKont); - return result; -} - -/* - (E.typeOf_expr(expr)) { - T_k(expr, fn (sexpr) { - k(E.typeOf_expr(sexpr)) - }) - } -*/ -static LamExp *cpsTkLamTypeOf(LamTypeOf *node, CpsKont *k) { - ENTER(cpsTkLamTypeOf); - CpsKont *k1 = makeKont_TkTypeOf(k); - int save = PROTECT(k1); - LamExp *result = cpsTk(node->exp, k1); - UNPROTECT(save); - LEAVE(cpsTkLamTypeOf); - return result; -} - -LamExp *TkTypeOfKont(LamExp *sexpr, TkTypeOfKontEnv *env) { - ENTER(TkTypeOfKont); - LamExp *typeOf_exp = makeLamExp_TypeOf(CPI(sexpr), sexpr); - int save = PROTECT(typeOf_exp); - LamExp *result = INVOKE(env->k, typeOf_exp); - UNPROTECT(save); - LEAVE(TkTypeOfKont); - return result; -} - -/* - (E.typeDefs(defs, expr)) { - E.typeDefs(defs, T_k(expr, k)) - } -*/ -static LamExp *cpsTkLamTypeDefs(LamTypeDefs *node, CpsKont *k) { - ENTER(cpsTkLamTypeDefs); - LamExp *expr = cpsTk(node->body, k); - int save = PROTECT(expr); - LamExp *result = makeLamExp_TypeDefs(CPI(node), node->typeDefs, expr); - UNPROTECT(save); - LEAVE(cpsTkLamTypeDefs); - return result; -} - /* (E.callCC_expr(e)) { let @@ -818,77 +566,57 @@ static LamExp *cpsTkLamTypeDefs(LamTypeDefs *node, CpsKont *k) { T_c(E.callCC_expr(e), c) } */ -static LamExp *cpsTkCallCC(LamExp *node, CpsKont *k) { +static MinExp *cpsTkCallCC(MinExp *node, CpsKont *k) { ENTER(cpsTkCallCC); - LamExp *c = kToC(CPI(node), k); + MinExp *c = kToC(CPI(node), k); int save = PROTECT(c); - LamExp *result = cpsTc(node, c); + MinExp *result = cpsTc(node, c); UNPROTECT(save); LEAVE(cpsTkCallCC); return result; } -static LamExp *cpsTkLamExp(LamExp *node, CpsKont *k) { - if (node == NULL) return NULL; +static MinExp *cpsTkMinExp(MinExp *node, CpsKont *k) { + if (node == NULL) + return NULL; if (isAexpr(node)) { - LamExp *expr = cpsM(node); + MinExp *expr = cpsM(node); int save = PROTECT(expr); - LamExp *result = INVOKE(k, expr); + MinExp *result = INVOKE(k, expr); UNPROTECT(save); return result; } switch (node->type) { - case LAMEXP_TYPE_AMB: - return cpsTkLamAmb(getLamExp_Amb(node), k); - case LAMEXP_TYPE_APPLY: - return cpsTkLamApply(node, k); - case LAMEXP_TYPE_CALLCC: - return cpsTkCallCC(getLamExp_CallCC(node), k); - case LAMEXP_TYPE_COND: - return cpsTkLamCond(getLamExp_Cond(node), k); - case LAMEXP_TYPE_CONSTRUCT: - return cpsTkLamConstruct(getLamExp_Construct(node), k); - case LAMEXP_TYPE_DECONSTRUCT: - return cpsTkLamDeconstruct(getLamExp_Deconstruct(node), k); - case LAMEXP_TYPE_IFF: - return cpsTkLamIff(getLamExp_Iff(node), k); - case LAMEXP_TYPE_LET: - return cpsTkLamLet(getLamExp_Let(node), k); - case LAMEXP_TYPE_LETSTAR: - return cpsTkLamLetStar(getLamExp_LetStar(node), k); - case LAMEXP_TYPE_LETREC: - return cpsTkLamLetRec(getLamExp_LetRec(node), k); - case LAMEXP_TYPE_LOOKUP: - return cpsTkLamLookUp(getLamExp_LookUp(node), k); - case LAMEXP_TYPE_MAKETUPLE: - return cpsTkMakeTuple(getLamExp_MakeTuple(node), k); - case LAMEXP_TYPE_MAKEVEC: - return cpsTkMakeVec(getLamExp_MakeVec(node), k); - case LAMEXP_TYPE_MATCH: - return cpsTkLamMatch(getLamExp_Match(node), k); - case LAMEXP_TYPE_NAMESPACES: - return cpsTkLamNameSpaceArray(getLamExp_NameSpaces(node), k); - case LAMEXP_TYPE_PRIM: - return cpsTkLamPrimApp(getLamExp_Prim(node), k); - case LAMEXP_TYPE_PRINT: - return cpsTkLamPrint(getLamExp_Print(node), k); - case LAMEXP_TYPE_SEQUENCE: - return cpsTkLamSequence(getLamExp_Sequence(node), k); - case LAMEXP_TYPE_TAG: - return cpsTkTag(getLamExp_Tag(node), k); - case LAMEXP_TYPE_TUPLEINDEX: - return cpsTkLamTupleIndex(getLamExp_TupleIndex(node), k); - case LAMEXP_TYPE_TYPEDEFS: - return cpsTkLamTypeDefs(getLamExp_TypeDefs(node), k); - case LAMEXP_TYPE_TYPEOF: - return cpsTkLamTypeOf(getLamExp_TypeOf(node), k); - default: - cant_happen("unrecognized LamExp type %s [%s %d]", - lamExpTypeName(node->type), - CPI(node).fileName, - CPI(node).lineNo); + case MINEXP_TYPE_AMB: + return cpsTkMinAmb(getMinExp_Amb(node), k); + case MINEXP_TYPE_APPLY: + return cpsTkMinApply(node, k); + case MINEXP_TYPE_CALLCC: + return cpsTkCallCC(getMinExp_CallCC(node), k); + case MINEXP_TYPE_COND: + return cpsTkMinCond(getMinExp_Cond(node), k); + case MINEXP_TYPE_IFF: + return cpsTkMinIff(getMinExp_Iff(node), k); + case MINEXP_TYPE_LETREC: + return cpsTkMinLetRec(getMinExp_LetRec(node), k); + case MINEXP_TYPE_LOOKUP: + return cpsTkMinLookUp(getMinExp_LookUp(node), k); + case MINEXP_TYPE_MAKEVEC: + return cpsTkMakeVec(getMinExp_MakeVec(node), k); + case MINEXP_TYPE_MATCH: + return cpsTkMinMatch(getMinExp_Match(node), k); + case MINEXP_TYPE_NAMESPACES: + return cpsTkMinNameSpaceArray(getMinExp_NameSpaces(node), k); + case MINEXP_TYPE_PRIM: + return cpsTkMinPrimApp(getMinExp_Prim(node), k); + case MINEXP_TYPE_SEQUENCE: + return cpsTkMinSequence(getMinExp_Sequence(node), k); + default: + cant_happen("unrecognized MinExp type %s [%s %d]", + minExpTypeName(node->type), CPI(node).fileName, + CPI(node).lineNo); } } @@ -899,58 +627,57 @@ static LamExp *cpsTkLamExp(LamExp *node, CpsKont *k) { }) } */ -static LamExp *cpsTkLamNameSpaceArray(LamNameSpaceArray *node, CpsKont *k) { - ENTER(cpsTkLamNameSpaceArray); - LamExp *seq = nsaToArgs(node); +static MinExp *cpsTkMinNameSpaceArray(MinNameSpaceArray *node, CpsKont *k) { + ENTER(cpsTkMinNameSpaceArray); + MinExp *seq = nsaToArgs(node); int save = PROTECT(seq); CpsKont *k1 = makeKont_TkNameSpaces(k); PROTECT(k1); - LamExp *result = cpsTs_k(seq, k1); + MinExp *result = cpsTs_k(seq, k1); UNPROTECT(save); - LEAVE(cpsTkLamNameSpaceArray); + LEAVE(cpsTkMinNameSpaceArray); return result; } -LamExp *TkNameSpacesKont(LamExp *sexprs, TkNameSpacesKontEnv *env) { +MinExp *TkNameSpacesKont(MinExp *sexprs, TkNameSpacesKontEnv *env) { ENTER(TkNameSpacesKont); - LamNameSpaceArray *nsa = argsToNsa(sexprs); + MinNameSpaceArray *nsa = argsToNsa(sexprs); int save = PROTECT(nsa); - LamExp *nsaExp = newLamExp_NameSpaces(CPI(sexprs), nsa); + MinExp *nsaExp = newMinExp_NameSpaces(CPI(sexprs), nsa); PROTECT(nsaExp); - LamExp *result = INVOKE(env->k, nsaExp); + MinExp *result = INVOKE(env->k, nsaExp); UNPROTECT(save); LEAVE(TkNameSpacesKont); return result; } -LamExp *nsaToArgs(LamNameSpaceArray *nsa) { +MinExp *nsaToArgs(MinNameSpaceArray *nsa) { ENTER(nsaToArgs); - LamArgs *args = NULL; + MinExprList *args = NULL; int save = PROTECT(NULL); for (Index i = nsa->size; i > 0; i--) { - LamExp *ns_exp = peeknLamNameSpaceArray(nsa, i - 1); - args = newLamArgs(CPI(ns_exp), ns_exp, args); + MinExp *ns_exp = peeknMinNameSpaceArray(nsa, i - 1); + args = newMinExprList(CPI(ns_exp), ns_exp, args); PROTECT(args); } - LamExp *result = newLamExp_Args(CPI(args), args); + MinExp *result = newMinExp_Args(CPI(args), args); UNPROTECT(save); LEAVE(nsaToArgs); return result; } -LamNameSpaceArray *argsToNsa(LamExp *args_exp) { +MinNameSpaceArray *argsToNsa(MinExp *args_exp) { ENTER(argsToNsa); - LamArgs *args = getLamExp_Args(args_exp); - LamNameSpaceArray *nsa = newLamNameSpaceArray(); + MinExprList *args = getMinExp_Args(args_exp); + MinNameSpaceArray *nsa = newMinNameSpaceArray(); int save = PROTECT(nsa); - for (LamArgs *current = args; current != NULL; current = current->next) { - pushLamNameSpaceArray(nsa, current->exp); + for (MinExprList *current = args; current != NULL; + current = current->next) { + pushMinNameSpaceArray(nsa, current->exp); } UNPROTECT(save); LEAVE(argsToNsa); return nsa; } -LamExp *cpsTk(LamExp *node, CpsKont *k) { - return cpsTkLamExp(node, k); -} +MinExp *cpsTk(MinExp *node, CpsKont *k) { return cpsTkMinExp(node, k); } diff --git a/src/lambda_desugar.c b/src/lambda_desugar.c new file mode 100644 index 00000000..08b98f4c --- /dev/null +++ b/src/lambda_desugar.c @@ -0,0 +1,867 @@ +/* + * 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 . + * + * Desugaring plain lambda structures to minimal lambda structures + */ + +#include "lambda.h" +#include "memory.h" +#include "minlam.h" +#include "minlam_pp.h" + +#include "lambda_desugar.h" +#include "lambda_pp.h" + +#ifdef DEBUG_LAMBDA_DESUGAR +#include "debugging_on.h" +#else +#include "debugging_off.h" +#endif + +// Forward declarations +static MinExp *desugarLamPrint(LamExp *); +static MinExp *desugarLamLet(LamExp *); +static MinExp *desugarLamLetStar(LamExp *); +static MinExp *desugarLamTypeOf(LamExp *); +static MinExp *desugarLamConstruct(LamExp *); +static MinExp *desugarLamDeconstruct(LamExp *); +static MinExp *desugarLamConstant(LamExp *); +static MinExp *desugarLamMakeTuple(LamExp *); +static MinExp *desugarLamTag(LamExp *); +static MinExp *desugarLamTupleIndex(LamExp *); +static MinExp *desugarLamTypeDefs(LamExp *); + +static MinLam *desugarLamLam(LamLam *node); +static SymbolList *desugarLamVarList(SymbolList *node); +static MinPrimApp *desugarLamPrimApp(LamPrimApp *node); +static MinExprList *desugarLamSequence(LamSequence *node); +static MinExprList *desugarLamArgs(LamArgs *node); +static MinApply *desugarLamApply(LamApply *node); +static MinLookUp *desugarLamLookUp(LamLookUp *node); +static MinExprList *desugarLamMakeVec(LamMakeVec *node); +static MinIff *desugarLamIff(LamIff *node); +static MinCond *desugarLamCond(LamCond *node); +static MinIntCondCases *desugarLamIntCondCases(LamIntCondCases *node); +static MinCharCondCases *desugarLamCharCondCases(LamCharCondCases *node); +static MinMatch *desugarLamMatch(LamMatch *node); +static MinMatchList *desugarLamMatchList(LamMatchList *node); +static MinIntList *desugarLamIntList(LamIntList *node); +static MinLetRec *desugarLamLetRec(LamLetRec *node); +static MinBindings *desugarLamBindings(LamBindings *node); +static MinAmb *desugarLamAmb(LamAmb *node); +static MinCondCases *desugarLamCondCases(LamCondCases *node); +static MinNameSpaceArray *desugarLamNameSpaceArray(LamNameSpaceArray *node); + +char *desugar_conversion_function = NULL; +int desugar_flag = 0; + +// Visitor implementations +static SymbolList *desugarLamVarList(SymbolList *node) { + ENTER(desugarLamVarList); + if (node == NULL) { + LEAVE(desugarLamVarList); + return NULL; + } + + // Pass through var (type: HashSymbol, not memory-managed) + SymbolList *new_next = desugarLamVarList(node->next); + int save = PROTECT(new_next); + SymbolList *this = newSymbolList(CPI(node), node->symbol, new_next); + + UNPROTECT(save); + LEAVE(desugarLamVarList); + return this; +} + +static MinPrimOp desugarLamPrimOp(LamPrimOp primOp) { + switch (primOp) { + case LAMPRIMOP_TYPE_ADD: + return MINPRIMOP_TYPE_ADD; + case LAMPRIMOP_TYPE_SUB: + return MINPRIMOP_TYPE_SUB; + case LAMPRIMOP_TYPE_MUL: + return MINPRIMOP_TYPE_MUL; + case LAMPRIMOP_TYPE_DIV: + return MINPRIMOP_TYPE_DIV; + case LAMPRIMOP_TYPE_MOD: + return MINPRIMOP_TYPE_MOD; + case LAMPRIMOP_TYPE_POW: + return MINPRIMOP_TYPE_POW; + case LAMPRIMOP_TYPE_EQ: + return MINPRIMOP_TYPE_EQ; + case LAMPRIMOP_TYPE_NE: + return MINPRIMOP_TYPE_NE; + case LAMPRIMOP_TYPE_GT: + return MINPRIMOP_TYPE_GT; + case LAMPRIMOP_TYPE_LT: + return MINPRIMOP_TYPE_LT; + case LAMPRIMOP_TYPE_GE: + return MINPRIMOP_TYPE_GE; + case LAMPRIMOP_TYPE_LE: + return MINPRIMOP_TYPE_LE; + case LAMPRIMOP_TYPE_CMP: + return MINPRIMOP_TYPE_CMP; + case LAMPRIMOP_TYPE_VEC: + return MINPRIMOP_TYPE_VEC; + default: + cant_happen("unrecognised %s", lamPrimOpName(primOp)); + } +} + +static MinPrimApp *desugarLamPrimApp(LamPrimApp *node) { + ENTER(desugarLamPrimApp); + if (node == NULL) { + LEAVE(desugarLamPrimApp); + return NULL; + } + + MinExp *new_exp1 = desugarLamExp(node->exp1); + int save = PROTECT(new_exp1); + MinExp *new_exp2 = desugarLamExp(node->exp2); + PROTECT(new_exp2); + MinPrimApp *result = newMinPrimApp(CPI(node), desugarLamPrimOp(node->type), + new_exp1, new_exp2); + UNPROTECT(save); + LEAVE(desugarLamPrimApp); + return result; +} + +static MinLam *desugarLamLam(LamLam *node) { + ENTER(desugarLamLam); + if (node == NULL) { + LEAVE(desugarLamLam); + return NULL; + } + + SymbolList *params = desugarLamVarList(node->args); + int save = PROTECT(params); + MinExp *body = desugarLamExp(node->exp); + PROTECT(body); + MinLam *result = newMinLam(CPI(node), params, body); + UNPROTECT(save); + LEAVE(desugarLamLam); + return result; +} + +static MinExprList *desugarLamSequence(LamSequence *node) { + ENTER(desugarLamSequence); + if (node == NULL) { + LEAVE(desugarLamSequence); + return NULL; + } + + MinExprList *next = desugarLamSequence(node->next); + int save = PROTECT(next); + MinExp *exp = desugarLamExp(node->exp); + PROTECT(exp); + MinExprList *result = newMinExprList(CPI(node), exp, next); + UNPROTECT(save); + LEAVE(desugarLamSequence); + return result; +} + +static MinExprList *desugarLamArgs(LamArgs *node) { + ENTER(desugarLamArgs); + if (node == NULL) { + LEAVE(desugarLamArgs); + return NULL; + } + + MinExprList *next = desugarLamArgs(node->next); + int save = PROTECT(next); + MinExp *exp = desugarLamExp(node->exp); + PROTECT(exp); + MinExprList *result = newMinExprList(CPI(node), exp, next); + UNPROTECT(save); + LEAVE(desugarLamArgs); + return result; +} + +static MinApply *desugarLamApply(LamApply *node) { + ENTER(desugarLamApply); + if (node == NULL) { + LEAVE(desugarLamApply); + return NULL; + } + + MinExp *function = desugarLamExp(node->function); + int save = PROTECT(function); + MinExprList *args = desugarLamArgs(node->args); + PROTECT(args); + MinApply *result = newMinApply(CPI(node), function, args); + UNPROTECT(save); + LEAVE(desugarLamApply); + return result; +} + +static MinLookUp *desugarLamLookUp(LamLookUp *node) { + ENTER(desugarLamLookUp); + if (node == NULL) { + LEAVE(desugarLamLookUp); + return NULL; + } + + MinExp *exp = desugarLamExp(node->exp); + int save = PROTECT(exp); + MinLookUp *result = newMinLookUp(CPI(node), node->nsId, exp); + UNPROTECT(save); + LEAVE(desugarLamLookUp); + return result; +} + +static MinExp *desugarLamConstant(LamExp *exp) { + ENTER(desugarLamConstant); + MinExp *result = newMinExp_Stdint(CPI(exp), getLamExp_Constant(exp)->tag); + LEAVE(desugarLamConstant); + return result; +} + +static LamMakeVec *constructToMakeVec(LamConstruct *construct) { + int nArgs = countLamArgs(construct->args); + LamExp *newArg = newLamExp_Stdint(CPI(construct), construct->tag); + int save = PROTECT(newArg); + LamArgs *extraItem = newLamArgs(CPI(construct), newArg, construct->args); + PROTECT(extraItem); + LamMakeVec *res = newLamMakeVec(CPI(construct), nArgs + 1, extraItem); + UNPROTECT(save); + return res; +} + +static MinExp *desugarLamConstruct(LamExp *exp) { + ENTER(desugarLamConstruct); + LamMakeVec *makeVec = constructToMakeVec(getLamExp_Construct(exp)); + int save = PROTECT(makeVec); + MinExprList *newMakeVec = desugarLamMakeVec(makeVec); + PROTECT(newMakeVec); + MinExp *result = newMinExp_MakeVec(CPI(exp), newMakeVec); + UNPROTECT(save); + return result; +} + +static LamPrimApp *deconstructToPrimApp(LamDeconstruct *deconstruct) { + LamExp *index = newLamExp_Stdint(CPI(deconstruct), deconstruct->vec); + int save = PROTECT(index); + LamPrimApp *res = newLamPrimApp(CPI(deconstruct), LAMPRIMOP_TYPE_VEC, index, + deconstruct->exp); + UNPROTECT(save); + return res; +} + +static MinExp *desugarLamDeconstruct(LamExp *exp) { + ENTER(desugarLamDeconstruct); + LamPrimApp *primApp = deconstructToPrimApp(getLamExp_Deconstruct(exp)); + int save = PROTECT(primApp); + MinPrimApp *newApp = desugarLamPrimApp(primApp); + PROTECT(newApp); + MinExp *result = newMinExp_Prim(CPI(exp), newApp); + UNPROTECT(save); + LEAVE(desugarLamDeconstruct); + return result; +} + +static LamPrimApp *tupleIndexToPrimApp(LamTupleIndex *tupleIndex) { + LamExp *index = newLamExp_Stdint(CPI(tupleIndex), tupleIndex->vec); + int save = PROTECT(index); + LamPrimApp *res = newLamPrimApp(CPI(tupleIndex), LAMPRIMOP_TYPE_VEC, index, + tupleIndex->exp); + UNPROTECT(save); + return res; +} + +static MinExp *desugarLamTupleIndex(LamExp *exp) { + ENTER(desugarLamTupleIndex); + LamPrimApp *app = tupleIndexToPrimApp(getLamExp_TupleIndex(exp)); + int save = PROTECT(app); + MinPrimApp *newApp = desugarLamPrimApp(app); + PROTECT(newApp); + MinExp *result = newMinExp_Prim(CPI(exp), newApp); + UNPROTECT(save); + LEAVE(desugarLamTupleIndex); + return result; +} + +static MinExprList *desugarLamMakeVec(LamMakeVec *node) { + ENTER(desugarLamMakeVec); + if (node == NULL) { + LEAVE(desugarLamMakeVec); + return NULL; + } + + MinExprList *result = desugarLamArgs(node->args); + LEAVE(desugarLamMakeVec); + return result; +} + +static MinIff *desugarLamIff(LamIff *node) { + ENTER(desugarLamIff); + if (node == NULL) { + LEAVE(desugarLamIff); + return NULL; + } + + MinExp *condition = desugarLamExp(node->condition); + int save = PROTECT(condition); + MinExp *consequent = desugarLamExp(node->consequent); + PROTECT(consequent); + MinExp *alternative = desugarLamExp(node->alternative); + PROTECT(alternative); + MinIff *result = newMinIff(CPI(node), condition, consequent, alternative); + UNPROTECT(save); + LEAVE(desugarLamIff); + return result; +} + +static MinCond *desugarLamCond(LamCond *node) { + ENTER(desugarLamCond); + if (node == NULL) { + LEAVE(desugarLamCond); + return NULL; + } + + MinExp *value = desugarLamExp(node->value); + int save = PROTECT(value); + MinCondCases *cases = desugarLamCondCases(node->cases); + PROTECT(cases); + MinCond *result = newMinCond(CPI(node), value, cases); + UNPROTECT(save); + LEAVE(desugarLamCond); + return result; +} + +static MinIntCondCases *desugarLamIntCondCases(LamIntCondCases *node) { + ENTER(desugarLamIntCondCases); + if (node == NULL) { + LEAVE(desugarLamIntCondCases); + return NULL; + } + + MinExp *body = desugarLamExp(node->body); + int save = PROTECT(body); + MinIntCondCases *next = desugarLamIntCondCases(node->next); + PROTECT(next); + MinIntCondCases *result = + newMinIntCondCases(CPI(node), node->constant, body, next); + UNPROTECT(save); + LEAVE(desugarLamIntCondCases); + return result; +} + +static MinCharCondCases *desugarLamCharCondCases(LamCharCondCases *node) { + ENTER(desugarLamCharCondCases); + if (node == NULL) { + LEAVE(desugarLamCharCondCases); + return NULL; + } + + MinExp *body = desugarLamExp(node->body); + int save = PROTECT(body); + MinCharCondCases *next = desugarLamCharCondCases(node->next); + PROTECT(next); + MinCharCondCases *result = + newMinCharCondCases(CPI(node), node->constant, body, next); + UNPROTECT(save); + LEAVE(desugarLamCharCondCases); + return result; +} + +static MinMatch *desugarLamMatch(LamMatch *node) { + ENTER(desugarLamMatch); + if (node == NULL) { + LEAVE(desugarLamMatch); + return NULL; + } + + MinExp *index = desugarLamExp(node->index); + int save = PROTECT(index); + MinMatchList *cases = desugarLamMatchList(node->cases); + PROTECT(cases); + MinMatch *result = newMinMatch(CPI(node), index, cases); + UNPROTECT(save); + LEAVE(desugarLamMatch); + return result; +} + +static MinMatchList *desugarLamMatchList(LamMatchList *node) { + ENTER(desugarLamMatchList); + if (node == NULL) { + LEAVE(desugarLamMatchList); + return NULL; + } + + MinIntList *matches = desugarLamIntList(node->matches); + int save = PROTECT(matches); + MinExp *body = desugarLamExp(node->body); + PROTECT(body); + MinMatchList *next = desugarLamMatchList(node->next); + PROTECT(next); + MinMatchList *result = newMinMatchList(CPI(node), matches, body, next); + UNPROTECT(save); + LEAVE(desugarLamMatchList); + return result; +} + +static MinIntList *desugarLamIntList(LamIntList *node) { + ENTER(desugarLamIntList); + if (node == NULL) { + LEAVE(desugarLamIntList); + return NULL; + } + + MinIntList *next = desugarLamIntList(node->next); + int save = PROTECT(next); + MinIntList *result = newMinIntList(CPI(node), node->item, next); + UNPROTECT(save); + LEAVE(desugarLamIntList); + return result; +} + +static SymbolList *extractKeysFromBindings(MinBindings *bindings) { + ENTER(extractKeysFromBindings); + if (bindings == NULL) { + LEAVE(extractKeysFromBindings); + return NULL; + } + SymbolList *next = extractKeysFromBindings(bindings->next); + int save = PROTECT(next); + SymbolList *result = newSymbolList(CPI(bindings), bindings->var, next); + UNPROTECT(save); + LEAVE(extractKeysFromBindings); + return result; +} + +static MinExprList *extractValuesFromBindings(MinBindings *bindings) { + ENTER(extractValuesFromBindings); + if (bindings == NULL) { + LEAVE(extractValuesFromBindings); + return NULL; + } + MinExprList *next = extractValuesFromBindings(bindings->next); + int save = PROTECT(next); + MinExprList *result = newMinExprList(CPI(bindings), bindings->val, next); + UNPROTECT(save); + LEAVE(extractValuesFromBindings); + return result; +} + +static MinExp *desugarLamLet(LamExp *exp) { + ENTER(desugarLamLet); + LamLet *node = getLamExp_Let(exp); + MinBindings *bindings = desugarLamBindings(node->bindings); + int save = PROTECT(bindings); + MinExp *body = desugarLamExp(node->body); + PROTECT(body); + SymbolList *fargs = extractKeysFromBindings(bindings); + PROTECT(fargs); + MinExp *lambda = makeMinExp_Lam(CPI(node), fargs, body); + PROTECT(lambda); + MinExprList *aargs = extractValuesFromBindings(bindings); + PROTECT(aargs); + MinExp *result = makeMinExp_Apply(CPI(node), lambda, aargs); + UNPROTECT(save); + LEAVE(desugarLamLet); + return result; +} + +static MinLetRec *desugarLamLetRec(LamLetRec *node) { + ENTER(desugarLamLetRec); + if (node == NULL) { + LEAVE(desugarLamLetRec); + return NULL; + } + + MinBindings *bindings = desugarLamBindings(node->bindings); + int save = PROTECT(bindings); + MinExp *body = desugarLamExp(node->body); + PROTECT(body); + MinLetRec *result = newMinLetRec(CPI(node), bindings, body); + UNPROTECT(save); + LEAVE(desugarLamLetRec); + return result; +} + +static LamExp *nestLets(LamBindings *bindings, LamExp *body) { + ENTER(nestLets); + if (bindings == NULL) { + LEAVE(nestLets); + return body; + } + LamExp *rest = nestLets(bindings->next, body); + int save = PROTECT(rest); + LamBindings *single_binding = + newLamBindings(CPI(bindings), bindings->var, bindings->val, NULL); + PROTECT(single_binding); + LamExp *let = makeLamExp_Let(CPI(bindings), single_binding, rest); + UNPROTECT(save); + LEAVE(nestLets); + return let; +} + +static MinExp *desugarLamLetStar(LamExp *exp) { + ENTER(desugarLamLetStar); + LamLetStar *node = getLamExp_LetStar(exp); + // build a nest of lets, then desugar that + LamExp *lets = nestLets(node->bindings, node->body); + int save = PROTECT(lets); + MinExp *result = desugarLamExp(lets); + UNPROTECT(save); + LEAVE(desugarLamLetStar); + return result; +} + +static MinBindings *desugarLamBindings(LamBindings *node) { + ENTER(desugarLamBindings); + if (node == NULL) { + LEAVE(desugarLamBindings); + return NULL; + } + + MinExp *val = desugarLamExp(node->val); + int save = PROTECT(val); + MinBindings *next = desugarLamBindings(node->next); + PROTECT(next); + MinBindings *result = newMinBindings(CPI(node), node->var, val, next); + if (desugar_conversion_function != NULL && + strcmp(node->var->name, desugar_conversion_function) == 0) { + ppMinExp(result->val); + eprintf("\n"); + exit(0); + } + UNPROTECT(save); + LEAVE(desugarLamBindings); + return result; +} + +static MinAmb *desugarLamAmb(LamAmb *node) { + ENTER(desugarLamAmb); + if (node == NULL) { + LEAVE(desugarLamAmb); + return NULL; + } + + MinExp *left = desugarLamExp(node->left); + int save = PROTECT(left); + MinExp *right = desugarLamExp(node->right); + PROTECT(right); + MinAmb *result = newMinAmb(CPI(node), left, right); + UNPROTECT(save); + LEAVE(desugarLamAmb); + return result; +} + +static MinExp *desugarLamTypeOf(LamExp *exp) { + ENTER(desugarLamTypeOf); + LamTypeOf *node = getLamExp_TypeOf(exp); + MinExp *result = desugarLamExp(node->typeString); + LEAVE(desugarLamTypeOf); + return result; +} + +static MinExp *desugarLamTypeDefs(LamExp *exp) { + ENTER(desugarLamTypeDefs); + MinExp *result = desugarLamExp(getLamExp_TypeDefs(exp)->body); + LEAVE(desugarLamTypeDefs); + return result; +} + +static MinExp *desugarLamPrint(LamExp *node) { + MinExp *printer = desugarLamExp(getLamExp_Print(node)->printer); + int save = PROTECT(printer); + MinExp *arg = desugarLamExp(getLamExp_Print(node)->exp); + PROTECT(arg); + MinExprList *args = newMinExprList(CPI(node), arg, NULL); + PROTECT(args); + MinExp *result = makeMinExp_Apply(CPI(node), printer, args); + UNPROTECT(save); + return result; +} + +static LamMakeVec *tupleToMakeVec(ParserInfo PI, LamArgs *tuple) { + int nArgs = countLamArgs(tuple); + LamMakeVec *res = newLamMakeVec(PI, nArgs, tuple); + return res; +} + +static MinExp *desugarLamMakeTuple(LamExp *exp) { + ENTER(desugarLamMakeTuple); + LamMakeVec *makeVec = tupleToMakeVec(CPI(exp), getLamExp_MakeTuple(exp)); + int save = PROTECT(makeVec); + MinExprList *minMakeVec = desugarLamMakeVec(makeVec); + PROTECT(minMakeVec); + MinExp *result = newMinExp_MakeVec(CPI(exp), minMakeVec); + UNPROTECT(save); + LEAVE(desugarLamMakeTuple); + return result; +} + +static LamPrimApp *tagToPrimApp(LamExp *tagged) { + LamExp *zero_index = newLamExp_Stdint(CPI(tagged), 0); + int save = PROTECT(zero_index); + LamPrimApp *res = + newLamPrimApp(CPI(tagged), LAMPRIMOP_TYPE_VEC, zero_index, tagged); + UNPROTECT(save); + return res; +} + +static MinExp *desugarLamTag(LamExp *exp) { + ENTER(desugarLamTag); + LamPrimApp *primApp = tagToPrimApp(getLamExp_Tag(exp)); + int save = PROTECT(primApp); + MinPrimApp *newApp = desugarLamPrimApp(primApp); + PROTECT(newApp); + MinExp *result = newMinExp_Prim(CPI(exp), newApp); + UNPROTECT(save); + LEAVE(desugarLamTag); + return result; +} + +static MinCondCases *desugarLamCondCases(LamCondCases *node) { + ENTER(desugarLamCondCases); + if (node == NULL) { + LEAVE(desugarLamCondCases); + return NULL; + } + + int save = PROTECT(NULL); + MinCondCases *result = NULL; + + switch (node->type) { + case LAMCONDCASES_TYPE_INTEGERS: { + // LamIntCondCases + MinIntCondCases *new = + desugarLamIntCondCases(getLamCondCases_Integers(node)); + PROTECT(new); + result = newMinCondCases_Integers(CPI(node), new); + break; + } + case LAMCONDCASES_TYPE_CHARACTERS: { + // LamCharCondCases + MinCharCondCases *new = + desugarLamCharCondCases(getLamCondCases_Characters(node)); + PROTECT(new); + result = newMinCondCases_Characters(CPI(node), new); + break; + } + default: + cant_happen("unrecognized LamCondCases type %d", node->type); + } + + UNPROTECT(save); + LEAVE(desugarLamCondCases); + return result; +} + +static MinNameSpaceArray *desugarLamNameSpaceArray(LamNameSpaceArray *node) { + ENTER(desugarLamNameSpaceArray); + if (node == NULL) { + LEAVE(desugarLamNameSpaceArray); + return NULL; + } + + MinNameSpaceArray *result = newMinNameSpaceArray(); + int save = PROTECT(result); + + // Iterate over all elements + for (Index i = 0; i < node->size; i++) { + LamExp *element = peeknLamNameSpaceArray(node, i); + struct MinExp *new = desugarLamExp(element); + int save2 = PROTECT(new); + pushMinNameSpaceArray(result, new); + UNPROTECT(save2); + } + + UNPROTECT(save); + LEAVE(desugarLamNameSpaceArray); + return result; +} + +// Main desugaring function and public interface +MinExp *desugarLamExp(LamExp *node) { + ENTER(desugarLamExp); + if (node == NULL) { + LEAVE(desugarLamExp); + return NULL; + } + MinExp *result = NULL; + int save = PROTECT(NULL); + switch (node->type) { + case LAMEXP_TYPE_AMB: { + MinAmb *new = desugarLamAmb(getLamExp_Amb(node)); + PROTECT(new); + result = newMinExp_Amb(CPI(node), new); + break; + } + case LAMEXP_TYPE_APPLY: { + MinApply *new = desugarLamApply(getLamExp_Apply(node)); + PROTECT(new); + result = newMinExp_Apply(CPI(node), new); + break; + } + case LAMEXP_TYPE_ARGS: { + MinExprList *new = desugarLamArgs(getLamExp_Args(node)); + PROTECT(new); + result = newMinExp_Args(CPI(node), new); + break; + } + case LAMEXP_TYPE_BACK: { + result = newMinExp_Back(CPI(node)); + break; + } + case LAMEXP_TYPE_BIGINTEGER: { + result = newMinExp_BigInteger(CPI(node), getLamExp_BigInteger(node)); + break; + } + case LAMEXP_TYPE_BINDINGS: { + // LamBindings + MinBindings *new = desugarLamBindings(getLamExp_Bindings(node)); + PROTECT(new); + result = newMinExp_Bindings(CPI(node), new); + break; + } + case LAMEXP_TYPE_CALLCC: { + // LamExp + MinExp *new_callcc = desugarLamExp(getLamExp_CallCC(node)); + PROTECT(new_callcc); + result = newMinExp_CallCC(CPI(node), new_callcc); + break; + } + case LAMEXP_TYPE_CHARACTER: { + result = newMinExp_Character(CPI(node), getLamExp_Character(node)); + break; + } + case LAMEXP_TYPE_COND: { + MinCond *new = desugarLamCond(getLamExp_Cond(node)); + PROTECT(new); + result = newMinExp_Cond(CPI(node), new); + break; + } + case LAMEXP_TYPE_CONSTANT: + result = desugarLamConstant(node); + break; + case LAMEXP_TYPE_CONSTRUCT: + result = desugarLamConstruct(node); + break; + case LAMEXP_TYPE_DECONSTRUCT: + result = desugarLamDeconstruct(node); + break; + case LAMEXP_TYPE_ERROR: { + result = newMinExp_Error(CPI(node)); + break; + } + case LAMEXP_TYPE_IFF: { + MinIff *new = desugarLamIff(getLamExp_Iff(node)); + PROTECT(new); + result = newMinExp_Iff(CPI(node), new); + break; + } + case LAMEXP_TYPE_LAM: { + MinLam *new = desugarLamLam(getLamExp_Lam(node)); + PROTECT(new); + result = newMinExp_Lam(CPI(node), new); + break; + } + case LAMEXP_TYPE_LET: + result = desugarLamLet(node); + break; + case LAMEXP_TYPE_LETREC: { + MinLetRec *new = desugarLamLetRec(getLamExp_LetRec(node)); + PROTECT(new); + result = newMinExp_LetRec(CPI(node), new); + break; + } + case LAMEXP_TYPE_LETSTAR: + result = desugarLamLetStar(node); + break; + case LAMEXP_TYPE_LOOKUP: { + MinLookUp *new = desugarLamLookUp(getLamExp_LookUp(node)); + PROTECT(new); + result = newMinExp_LookUp(CPI(node), new); + break; + } + case LAMEXP_TYPE_MAKETUPLE: + result = desugarLamMakeTuple(node); + break; + case LAMEXP_TYPE_MAKEVEC: { + MinExprList *new = desugarLamMakeVec(getLamExp_MakeVec(node)); + PROTECT(new); + result = newMinExp_MakeVec(CPI(node), new); + break; + } + case LAMEXP_TYPE_MATCH: { + MinMatch *new = desugarLamMatch(getLamExp_Match(node)); + PROTECT(new); + result = newMinExp_Match(CPI(node), new); + break; + } + case LAMEXP_TYPE_NAMESPACES: { + MinNameSpaceArray *new = + desugarLamNameSpaceArray(getLamExp_NameSpaces(node)); + PROTECT(new); + result = newMinExp_NameSpaces(CPI(node), new); + break; + } + case LAMEXP_TYPE_PRIM: { + // Check if the type checker created a replacement (bespoke comparator) + LamPrimApp *prim = getLamExp_Prim(node); + if (prim->replacement != NULL) { + // Use the replacement instead of the primitive + result = desugarLamExp(prim->replacement); + } else { + MinPrimApp *new = desugarLamPrimApp(prim); + PROTECT(new); + result = newMinExp_Prim(CPI(node), new); + } + break; + } + case LAMEXP_TYPE_PRINT: + result = desugarLamPrint(node); + break; + case LAMEXP_TYPE_SEQUENCE: { + MinExprList *new = desugarLamSequence(getLamExp_Sequence(node)); + PROTECT(new); + result = newMinExp_Sequence(CPI(node), new); + break; + } + case LAMEXP_TYPE_STDINT: + result = newMinExp_Stdint(CPI(node), getLamExp_Stdint(node)); + break; + case LAMEXP_TYPE_TAG: + result = desugarLamTag(node); + break; + case LAMEXP_TYPE_TUPLEINDEX: + result = desugarLamTupleIndex(node); + break; + case LAMEXP_TYPE_TYPEDEFS: + result = desugarLamTypeDefs(node); + break; + case LAMEXP_TYPE_TYPEOF: + result = desugarLamTypeOf(node); + break; + case LAMEXP_TYPE_VAR: { + result = newMinExp_Var(CPI(node), getLamExp_Var(node)); + break; + } + case LAMEXP_TYPE_ENV: { + result = newMinExp_Env(CPI(node)); + break; + } + default: + cant_happen("unexpected LamExp type %s", lamExpTypeName(node->type)); + } + UNPROTECT(save); + LEAVE(desugarLamExp); + return result; +} \ No newline at end of file diff --git a/src/lambda_desugar.h b/src/lambda_desugar.h new file mode 100644 index 00000000..320c8187 --- /dev/null +++ b/src/lambda_desugar.h @@ -0,0 +1,29 @@ +#ifndef cekf_lambda_desugar_h +#define cekf_lambda_desugar_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 "lambda.h" +#include "minlam.h" + +MinExp *desugarLamExp(LamExp *node); + +extern char *desugar_conversion_function; +extern int desugar_flag; + +#endif diff --git a/src/lambda_functions.h b/src/lambda_functions.h index d4f1d9ef..20b98a9b 100644 --- a/src/lambda_functions.h +++ b/src/lambda_functions.h @@ -1,28 +1,30 @@ #ifndef cekf_lambda_functions_h -# define cekf_lambda_functions_h +#define cekf_lambda_functions_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2025 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 . */ -struct LamExp; +struct MinExp; struct AnfKontEnv; struct CpsKontEnv; -typedef struct LamExp *(*AnfKontProcWrapper)(struct LamExp *, struct AnfKontEnv *); -typedef struct LamExp *(*CpsKontProcWrapper)(struct LamExp *, struct CpsKontEnv *); +typedef struct MinExp *(*AnfKontProcWrapper)(struct MinExp *, + struct AnfKontEnv *); +typedef struct MinExp *(*CpsKontProcWrapper)(struct MinExp *, + struct CpsKontEnv *); #endif diff --git a/src/lambda_pp.c b/src/lambda_pp.c index 61607b50..3c799a5c 100644 --- a/src/lambda_pp.c +++ b/src/lambda_pp.c @@ -56,17 +56,17 @@ void ppLamAmb(LamAmb *amb) { eprintf(")"); } -static void _ppLamVarList(LamVarList *varList) { +static void _ppLamVarList(SymbolList *varList) { if (varList == NULL) return; - ppHashSymbol(varList->var); + ppHashSymbol(varList->symbol); if (varList->next != NULL) { eprintf(" "); _ppLamVarList(varList->next); } } -void ppLamVarList(LamVarList *varList) { +void ppLamVarList(SymbolList *varList) { eprintf("("); _ppLamVarList(varList); eprintf(")"); diff --git a/src/lambda_pp.h b/src/lambda_pp.h index 502c216a..177ae9f6 100644 --- a/src/lambda_pp.h +++ b/src/lambda_pp.h @@ -25,7 +25,7 @@ void ppLamExpD(LamExp *exp, int depth); void ppLamLam(LamLam *lam); -void ppLamVarList(LamVarList *varList); +void ppLamVarList(SymbolList *varList); void ppLamExp(LamExp *exp); void ppHashSymbol(HashSymbol *symbol); void ppLamPrimApp(LamPrimApp *primApp); diff --git a/src/lambda_simplfication.c b/src/lambda_simplfication.c index ac739d29..ad45faea 100644 --- a/src/lambda_simplfication.c +++ b/src/lambda_simplfication.c @@ -1,33 +1,33 @@ /* * 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 . */ -#include -#include #include "common.h" +#include "lambda_debug.h" +#include "lambda_pp.h" #include "lambda_simplification.h" #include "symbol.h" -#include "lambda_pp.h" -#include "lambda_debug.h" +#include +#include #ifdef DEBUG_LAMBDA_SIMPLIFICATION -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif static LamExp *performLamSimplifications(LamLam *lam) { @@ -51,9 +51,7 @@ static LamExp *performLamSimplifications(LamLam *lam) { return newLamExp_Lam(CPI(lam), lam); } -static HashSymbol *performVarSimplifications(HashSymbol *var) { - return var; -} +static HashSymbol *performVarSimplifications(HashSymbol *var) { return var; } static LamPrimApp *performPrimSimplifications(LamPrimApp *prim) { ENTER(performPrimSimplifications); @@ -69,8 +67,7 @@ static LamSequence *_performSequenceSimplifications(LamSequence *sequence) { LEAVE(_performSequenceSimplifications); return NULL; } - sequence->next = - _performSequenceSimplifications(sequence->next); + sequence->next = _performSequenceSimplifications(sequence->next); sequence->exp = lamPerformSimplifications(sequence->exp); LEAVE(_performSequenceSimplifications); return sequence; @@ -78,7 +75,8 @@ static LamSequence *_performSequenceSimplifications(LamSequence *sequence) { #define SIMPLIFY_SINGLE_SEQUENCE -static LamExp *performSequenceSimplifications(ParserInfo I, LamSequence *sequence) { +static LamExp *performSequenceSimplifications(ParserInfo I, + LamSequence *sequence) { sequence = _performSequenceSimplifications(sequence); #ifdef SIMPLIFY_SINGLE_SEQUENCE if (countLamSequence(sequence) == 1) { @@ -103,7 +101,8 @@ static LamArgs *performArgsSimplifications(LamArgs *list) { return list; } -static LamTupleIndex *performTupleIndexSimplifications(LamTupleIndex *tupleIndex) { +static LamTupleIndex * +performTupleIndexSimplifications(LamTupleIndex *tupleIndex) { tupleIndex->exp = lamPerformSimplifications(tupleIndex->exp); return tupleIndex; } @@ -134,7 +133,8 @@ static LamMakeVec *performMakeVecSimplifications(LamMakeVec *makeVec) { return makeVec; } -static LamDeconstruct *performDeconstructSimplifications(LamDeconstruct *deconstruct) { +static LamDeconstruct * +performDeconstructSimplifications(LamDeconstruct *deconstruct) { ENTER(performDeconstructSimplifications); deconstruct->exp = lamPerformSimplifications(deconstruct->exp); LEAVE(performDeconstructSimplifications); @@ -148,7 +148,8 @@ static LamConstruct *performConstructSimplifications(LamConstruct *construct) { return construct; } -static LamBindings *makeLetBindings(ParserInfo I, LamArgs *aargs, LamVarList *fargs) { +static LamBindings *makeLetBindings(ParserInfo I, LamArgs *aargs, + SymbolList *fargs) { ENTER(makeLetBindings); if (aargs == NULL || fargs == NULL) { LEAVE(makeLetBindings); @@ -156,7 +157,7 @@ static LamBindings *makeLetBindings(ParserInfo I, LamArgs *aargs, LamVarList *fa } LamBindings *next = makeLetBindings(I, aargs->next, fargs->next); int save = PROTECT(next); - LamBindings *this = newLamBindings(I, fargs->var, aargs->exp, next); + LamBindings *this = newLamBindings(I, fargs->symbol, aargs->exp, next); UNPROTECT(save); LEAVE(makeLetBindings); return this; @@ -170,13 +171,11 @@ static LamExp *performApplySimplifications(LamApply *apply) { // Convert inline lambdas to let expressions LamLam *lam = getLamExp_Lam(apply->function); LamArgs *aargs = apply->args; - LamVarList *fargs = lam->args; - if (countLamArgs(aargs) == countLamVarList(fargs)) { + SymbolList *fargs = lam->args; + if (countLamArgs(aargs) == countSymbolList(fargs)) { LamBindings *bindings = makeLetBindings(CPI(apply), aargs, fargs); int save = PROTECT(bindings); - LamLet *let = newLamLet(CPI(apply), bindings, lam->exp); - PROTECT(let); - LamExp *exp = newLamExp_Let(CPI(apply), let); + LamExp *exp = makeLamExp_Let(CPI(apply), bindings, lam->exp); UNPROTECT(save); LEAVE(performApplySimplifications); return exp; @@ -278,7 +277,8 @@ static LamAmb *performAmbSimplifications(LamAmb *amb) { return amb; } -static LamIntCondCases *performIntCondCaseSimplifications(LamIntCondCases *cases) { +static LamIntCondCases * +performIntCondCaseSimplifications(LamIntCondCases *cases) { ENTER(performIntCondCaseSimplifications); if (cases == NULL) { LEAVE(performIntCondCaseSimplifications); @@ -290,7 +290,8 @@ static LamIntCondCases *performIntCondCaseSimplifications(LamIntCondCases *cases return cases; } -static LamCharCondCases *performCharCondCaseSimplifications(LamCharCondCases *cases) { +static LamCharCondCases * +performCharCondCaseSimplifications(LamCharCondCases *cases) { ENTER(performCharCondCaseSimplifications); if (cases == NULL) { LEAVE(performCharCondCaseSimplifications); @@ -309,14 +310,17 @@ static LamCondCases *performCondCaseSimplifications(LamCondCases *cases) { return NULL; } switch (cases->type) { - case LAMCONDCASES_TYPE_INTEGERS: - setLamCondCases_Integers(cases, performIntCondCaseSimplifications(getLamCondCases_Integers(cases))); - break; - case LAMCONDCASES_TYPE_CHARACTERS: - setLamCondCases_Characters(cases, performCharCondCaseSimplifications(getLamCondCases_Characters(cases))); - break; - default: - cant_happen("unrecognised %s", lamCondCasesTypeName(cases->type)); + case LAMCONDCASES_TYPE_INTEGERS: + setLamCondCases_Integers(cases, performIntCondCaseSimplifications( + getLamCondCases_Integers(cases))); + break; + case LAMCONDCASES_TYPE_CHARACTERS: + setLamCondCases_Characters(cases, + performCharCondCaseSimplifications( + getLamCondCases_Characters(cases))); + break; + default: + cant_happen("unrecognised %s", lamCondCasesTypeName(cases->type)); } LEAVE(performCondCaseSimplifications); return cases; @@ -330,9 +334,11 @@ static LamCond *performCondSimplifications(LamCond *cond) { return cond; } -static LamNameSpaceArray *performNameSpacesSimplifications(LamNameSpaceArray *nameSpaces) { +static LamNameSpaceArray * +performNameSpacesSimplifications(LamNameSpaceArray *nameSpaces) { for (Index i = 0; i < nameSpaces->size; i++) { - nameSpaces->entries[i] = lamPerformSimplifications(nameSpaces->entries[i]); + nameSpaces->entries[i] = + lamPerformSimplifications(nameSpaces->entries[i]); } return nameSpaces; } @@ -343,89 +349,106 @@ LamExp *lamPerformSimplifications(LamExp *exp) { // eprintf("\n"); if (exp != NULL) { switch (exp->type) { - case LAMEXP_TYPE_BIGINTEGER: - case LAMEXP_TYPE_STDINT: - case LAMEXP_TYPE_CHARACTER: - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_CONSTANT: - case LAMEXP_TYPE_CONSTRUCTOR: - case LAMEXP_TYPE_ENV: - break; - case LAMEXP_TYPE_LAM: - exp = performLamSimplifications(getLamExp_Lam(exp)); - break; - case LAMEXP_TYPE_APPLY: - exp = performApplySimplifications(getLamExp_Apply(exp)); - break; - case LAMEXP_TYPE_VAR: - setLamExp_Var(exp, performVarSimplifications(getLamExp_Var(exp))); - break; - case LAMEXP_TYPE_PRIM: - setLamExp_Prim(exp, performPrimSimplifications(getLamExp_Prim(exp))); - break; - case LAMEXP_TYPE_SEQUENCE: - exp = performSequenceSimplifications(CPI(exp), getLamExp_Sequence(exp)); - break; - case LAMEXP_TYPE_MAKEVEC: - setLamExp_MakeVec(exp, performMakeVecSimplifications(getLamExp_MakeVec(exp))); - break; - case LAMEXP_TYPE_DECONSTRUCT: - setLamExp_Deconstruct(exp, performDeconstructSimplifications(getLamExp_Deconstruct(exp))); - break; - case LAMEXP_TYPE_CONSTRUCT: - setLamExp_Construct(exp, performConstructSimplifications(getLamExp_Construct(exp))); - break; - case LAMEXP_TYPE_TAG: - setLamExp_Tag(exp, lamPerformSimplifications(getLamExp_Tag(exp))); - break; - case LAMEXP_TYPE_IFF: - setLamExp_Iff(exp, performIffSimplifications(getLamExp_Iff(exp))); - break; - case LAMEXP_TYPE_COND: - setLamExp_Cond(exp, performCondSimplifications(getLamExp_Cond(exp))); - break; - case LAMEXP_TYPE_CALLCC: - setLamExp_CallCC(exp, lamPerformSimplifications(getLamExp_CallCC(exp))); - break; - case LAMEXP_TYPE_LET: - setLamExp_Let(exp, performLetSimplifications(getLamExp_Let(exp))); - break; - case LAMEXP_TYPE_LETREC: - setLamExp_LetRec(exp, performLetRecSimplifications(getLamExp_LetRec(exp))); - break; - case LAMEXP_TYPE_LETSTAR: - setLamExp_LetStar(exp, performLetStarSimplifications(getLamExp_LetStar(exp))); - break; - case LAMEXP_TYPE_TYPEDEFS: - setLamExp_TypeDefs(exp, performTypeDefsSimplifications(getLamExp_TypeDefs(exp))); - break; - case LAMEXP_TYPE_MATCH: - setLamExp_Match(exp, performMatchSimplifications(getLamExp_Match(exp))); - break; - case LAMEXP_TYPE_AMB: - setLamExp_Amb(exp, performAmbSimplifications(getLamExp_Amb(exp))); - break; - case LAMEXP_TYPE_MAKETUPLE: - setLamExp_MakeTuple(exp, performArgsSimplifications(getLamExp_MakeTuple(exp))); - break; - case LAMEXP_TYPE_TUPLEINDEX: - setLamExp_TupleIndex(exp, performTupleIndexSimplifications(getLamExp_TupleIndex(exp))); - break; - case LAMEXP_TYPE_PRINT: - setLamExp_Print(exp, performPrintSimplifications(getLamExp_Print(exp))); - break; - case LAMEXP_TYPE_TYPEOF: - setLamExp_TypeOf(exp, performTypeOfSimplifications(getLamExp_TypeOf(exp))); - break; - case LAMEXP_TYPE_LOOKUP: - setLamExp_LookUp(exp, performLookUpSimplifications(getLamExp_LookUp(exp))); - break; - case LAMEXP_TYPE_NAMESPACES: - setLamExp_NameSpaces(exp, performNameSpacesSimplifications(getLamExp_NameSpaces(exp))); - break; - default: - cant_happen("unrecognized %s", lamExpTypeName(exp->type)); + case LAMEXP_TYPE_BIGINTEGER: + case LAMEXP_TYPE_STDINT: + case LAMEXP_TYPE_CHARACTER: + case LAMEXP_TYPE_BACK: + case LAMEXP_TYPE_ERROR: + case LAMEXP_TYPE_CONSTANT: + case LAMEXP_TYPE_CONSTRUCTOR: + case LAMEXP_TYPE_ENV: + break; + case LAMEXP_TYPE_LAM: + exp = performLamSimplifications(getLamExp_Lam(exp)); + break; + case LAMEXP_TYPE_APPLY: + exp = performApplySimplifications(getLamExp_Apply(exp)); + break; + case LAMEXP_TYPE_VAR: + setLamExp_Var(exp, performVarSimplifications(getLamExp_Var(exp))); + break; + case LAMEXP_TYPE_PRIM: + setLamExp_Prim(exp, + performPrimSimplifications(getLamExp_Prim(exp))); + break; + case LAMEXP_TYPE_SEQUENCE: + exp = performSequenceSimplifications(CPI(exp), + getLamExp_Sequence(exp)); + break; + case LAMEXP_TYPE_MAKEVEC: + setLamExp_MakeVec( + exp, performMakeVecSimplifications(getLamExp_MakeVec(exp))); + break; + case LAMEXP_TYPE_DECONSTRUCT: + setLamExp_Deconstruct(exp, performDeconstructSimplifications( + getLamExp_Deconstruct(exp))); + break; + case LAMEXP_TYPE_CONSTRUCT: + setLamExp_Construct( + exp, performConstructSimplifications(getLamExp_Construct(exp))); + break; + case LAMEXP_TYPE_TAG: + setLamExp_Tag(exp, lamPerformSimplifications(getLamExp_Tag(exp))); + break; + case LAMEXP_TYPE_IFF: + setLamExp_Iff(exp, performIffSimplifications(getLamExp_Iff(exp))); + break; + case LAMEXP_TYPE_COND: + setLamExp_Cond(exp, + performCondSimplifications(getLamExp_Cond(exp))); + break; + case LAMEXP_TYPE_CALLCC: + setLamExp_CallCC(exp, + lamPerformSimplifications(getLamExp_CallCC(exp))); + break; + case LAMEXP_TYPE_LET: + setLamExp_Let(exp, performLetSimplifications(getLamExp_Let(exp))); + break; + case LAMEXP_TYPE_LETREC: + setLamExp_LetRec( + exp, performLetRecSimplifications(getLamExp_LetRec(exp))); + break; + case LAMEXP_TYPE_LETSTAR: + setLamExp_LetStar( + exp, performLetStarSimplifications(getLamExp_LetStar(exp))); + break; + case LAMEXP_TYPE_TYPEDEFS: + setLamExp_TypeDefs( + exp, performTypeDefsSimplifications(getLamExp_TypeDefs(exp))); + break; + case LAMEXP_TYPE_MATCH: + setLamExp_Match(exp, + performMatchSimplifications(getLamExp_Match(exp))); + break; + case LAMEXP_TYPE_AMB: + setLamExp_Amb(exp, performAmbSimplifications(getLamExp_Amb(exp))); + break; + case LAMEXP_TYPE_MAKETUPLE: + setLamExp_MakeTuple( + exp, performArgsSimplifications(getLamExp_MakeTuple(exp))); + break; + case LAMEXP_TYPE_TUPLEINDEX: + setLamExp_TupleIndex(exp, performTupleIndexSimplifications( + getLamExp_TupleIndex(exp))); + break; + case LAMEXP_TYPE_PRINT: + setLamExp_Print(exp, + performPrintSimplifications(getLamExp_Print(exp))); + break; + case LAMEXP_TYPE_TYPEOF: + setLamExp_TypeOf( + exp, performTypeOfSimplifications(getLamExp_TypeOf(exp))); + break; + case LAMEXP_TYPE_LOOKUP: + setLamExp_LookUp( + exp, performLookUpSimplifications(getLamExp_LookUp(exp))); + break; + case LAMEXP_TYPE_NAMESPACES: + setLamExp_NameSpaces(exp, performNameSpacesSimplifications( + getLamExp_NameSpaces(exp))); + break; + default: + cant_happen("unrecognized %s", lamExpTypeName(exp->type)); } } LEAVE(lamPerformSimplifications); diff --git a/src/lambda_substitution.c b/src/lambda_substitution.c index b3c914d0..3623ae5f 100644 --- a/src/lambda_substitution.c +++ b/src/lambda_substitution.c @@ -18,53 +18,40 @@ // Substitution of variables in the bodies of functions, called by the TPMC. -#include -#include -#include -#include "common.h" #include "lambda_substitution.h" +#include "ast_debug.h" +#include "common.h" #include "lambda_helper.h" +#include "print_generator.h" #include "symbols.h" #include "tpmc_logic.h" -#include "ast_debug.h" -#include "print_generator.h" +#include +#include +#include #ifdef DEBUG_LAMBDA_SUBSTITUTE -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif -static HashSymbol *performVarSubstitutions(HashSymbol *var, TpmcSubstitutionTable - *substitutions); +static HashSymbol *performVarSubstitutions(HashSymbol *var, + SymbolMap *substitutions); -static void substError(ParserInfo PI, const char *message, ...) __attribute__((format(printf, 2, 3))); - -static void substError(ParserInfo PI, const char *message, ...) __attribute__((unused)); - -static void substError(ParserInfo PI, const char *message, ...) { - va_list args; - va_start(args, message); - vfprintf(errout, message, args); - va_end(args); - can_happen(" at +%d %s", PI.lineNo, PI.fileName); -} - -static LamVarList *performVarListSubstitutions(LamVarList *varList, TpmcSubstitutionTable - *substitutions) { +static SymbolList *performVarListSubstitutions(SymbolList *varList, + SymbolMap *substitutions) { ENTER(performVarListSubstitutions); if (varList == NULL) { LEAVE(performVarListSubstitutions); return NULL; } varList->next = performVarListSubstitutions(varList->next, substitutions); - varList->var = performVarSubstitutions(varList->var, substitutions); + varList->symbol = performVarSubstitutions(varList->symbol, substitutions); LEAVE(performVarListSubstitutions); return varList; } -static LamLam *performLamSubstitutions(LamLam *lam, - TpmcSubstitutionTable *substitutions) { +static LamLam *performLamSubstitutions(LamLam *lam, SymbolMap *substitutions) { ENTER(performLamSubstitutions); lam->args = performVarListSubstitutions(lam->args, substitutions); lam->exp = lamPerformSubstitutions(lam->exp, substitutions); @@ -72,19 +59,19 @@ static LamLam *performLamSubstitutions(LamLam *lam, return lam; } -static HashSymbol *performVarSubstitutions(HashSymbol *var, TpmcSubstitutionTable - *substitutions) { +static HashSymbol *performVarSubstitutions(HashSymbol *var, + SymbolMap *substitutions) { ENTER(performVarSubstitutions); HashSymbol *replacement = NULL; - if (getTpmcSubstitutionTable(substitutions, var, &replacement)) { + if (getSymbolMap(substitutions, var, &replacement)) { return replacement; } LEAVE(performVarSubstitutions); return var; } -static LamPrimApp *performPrimSubstitutions(LamPrimApp *prim, TpmcSubstitutionTable - *substitutions) { +static LamPrimApp *performPrimSubstitutions(LamPrimApp *prim, + SymbolMap *substitutions) { ENTER(performPrimSubstitutions); prim->exp1 = lamPerformSubstitutions(prim->exp1, substitutions); prim->exp2 = lamPerformSubstitutions(prim->exp2, substitutions); @@ -92,8 +79,8 @@ static LamPrimApp *performPrimSubstitutions(LamPrimApp *prim, TpmcSubstitutionTa return prim; } -static LamSequence *performSequenceSubstitutions(LamSequence *sequence, TpmcSubstitutionTable - *substitutions) { +static LamSequence *performSequenceSubstitutions(LamSequence *sequence, + SymbolMap *substitutions) { ENTER(performSequenceSubstitutions); if (sequence == NULL) { LEAVE(performSequenceSubstitutions); @@ -106,8 +93,8 @@ static LamSequence *performSequenceSubstitutions(LamSequence *sequence, TpmcSubs return sequence; } -static LamArgs *performArgsSubstitutions(LamArgs *list, TpmcSubstitutionTable - *substitutions) { +static LamArgs *performArgsSubstitutions(LamArgs *list, + SymbolMap *substitutions) { ENTER(performArgsSubstitutions); if (list == NULL) { LEAVE(performArgsSubstitutions); @@ -120,57 +107,57 @@ static LamArgs *performArgsSubstitutions(LamArgs *list, TpmcSubstitutionTable } static LamTupleIndex *performTupleIndexSubstitutions(LamTupleIndex *tupleIndex, - TpmcSubstitutionTable *substitutions) { + SymbolMap *substitutions) { tupleIndex->exp = lamPerformSubstitutions(tupleIndex->exp, substitutions); return tupleIndex; } -static LamPrint *performPrintSubstitutions(LamPrint *print, TpmcSubstitutionTable *substitutions) { +static LamPrint *performPrintSubstitutions(LamPrint *print, + SymbolMap *substitutions) { print->exp = lamPerformSubstitutions(print->exp, substitutions); print->printer = lamPerformSubstitutions(print->printer, substitutions); return print; } -static LamLookUp *performLookUpSubstitutions(LamLookUp *lookUp, TpmcSubstitutionTable *substitutions) { +static LamLookUp *performLookUpSubstitutions(LamLookUp *lookUp, + SymbolMap *substitutions) { lookUp->exp = lamPerformSubstitutions(lookUp->exp, substitutions); return lookUp; } -static LamTypeOf *performTypeOfSubstitutions(LamTypeOf *typeOf, TpmcSubstitutionTable - *substitutions) { +static LamTypeOf *performTypeOfSubstitutions(LamTypeOf *typeOf, + SymbolMap *substitutions) { typeOf->exp = lamPerformSubstitutions(typeOf->exp, substitutions); return typeOf; } -static LamMakeVec *performMakeVecSubstitutions(LamMakeVec *makeVec, TpmcSubstitutionTable - *substitutions) { +static LamMakeVec *performMakeVecSubstitutions(LamMakeVec *makeVec, + SymbolMap *substitutions) { ENTER(performMakeVecSubstitutions); makeVec->args = performArgsSubstitutions(makeVec->args, substitutions); LEAVE(performMakeVecSubstitutions); return makeVec; } -static LamDeconstruct *performDeconstructSubstitutions(LamDeconstruct - *deconstruct, TpmcSubstitutionTable - *substitutions) { +static LamDeconstruct * +performDeconstructSubstitutions(LamDeconstruct *deconstruct, + SymbolMap *substitutions) { ENTER(performDeconstructSubstitutions); - deconstruct->exp = - lamPerformSubstitutions(deconstruct->exp, substitutions); + deconstruct->exp = lamPerformSubstitutions(deconstruct->exp, substitutions); LEAVE(performDeconstructSubstitutions); return deconstruct; } -static LamConstruct *performConstructSubstitutions(LamConstruct *construct, TpmcSubstitutionTable - *substitutions) { +static LamConstruct *performConstructSubstitutions(LamConstruct *construct, + SymbolMap *substitutions) { ENTER(performConstructSubstitutions); - construct->args = - performArgsSubstitutions(construct->args, substitutions); + construct->args = performArgsSubstitutions(construct->args, substitutions); LEAVE(performConstructSubstitutions); return construct; } -static LamApply *performApplySubstitutions(LamApply *apply, TpmcSubstitutionTable - *substitutions) { +static LamApply *performApplySubstitutions(LamApply *apply, + SymbolMap *substitutions) { ENTER(performApplySubstitutions); apply->function = lamPerformSubstitutions(apply->function, substitutions); apply->args = performArgsSubstitutions(apply->args, substitutions); @@ -178,18 +165,17 @@ static LamApply *performApplySubstitutions(LamApply *apply, TpmcSubstitutionTabl return apply; } -static LamIff *performIffSubstitutions(LamIff *iff, - TpmcSubstitutionTable *substitutions) { +static LamIff *performIffSubstitutions(LamIff *iff, SymbolMap *substitutions) { ENTER(performIffSubstitutions); iff->condition = lamPerformSubstitutions(iff->condition, substitutions); iff->consequent = lamPerformSubstitutions(iff->consequent, substitutions); - iff->alternative = - lamPerformSubstitutions(iff->alternative, substitutions); + iff->alternative = lamPerformSubstitutions(iff->alternative, substitutions); LEAVE(performIffSubstitutions); return iff; } -static LamBindings *performBindingsSubstitutions(LamBindings *bindings, TpmcSubstitutionTable *substitutions) { +static LamBindings *performBindingsSubstitutions(LamBindings *bindings, + SymbolMap *substitutions) { ENTER(performBindingsSubstitutions); if (bindings == NULL) { LEAVE(performBindingsSubstitutions); @@ -204,7 +190,7 @@ static LamBindings *performBindingsSubstitutions(LamBindings *bindings, TpmcSubs } static LamBindings *performLetBindingsSubstitutions(LamBindings *bindings, - TpmcSubstitutionTable *substitutions) { + SymbolMap *substitutions) { ENTER(performLetBindingsSubstitutions); if (bindings == NULL) { LEAVE(performLetBindingsSubstitutions); @@ -218,17 +204,17 @@ static LamBindings *performLetBindingsSubstitutions(LamBindings *bindings, return bindings; } -static LamLet *performLetSubstitutions(LamLet *let, - TpmcSubstitutionTable *substitutions) { +static LamLet *performLetSubstitutions(LamLet *let, SymbolMap *substitutions) { ENTER(performLetSubstitutions); - let->bindings = performLetBindingsSubstitutions(let->bindings, substitutions); + let->bindings = + performLetBindingsSubstitutions(let->bindings, substitutions); let->body = lamPerformSubstitutions(let->body, substitutions); LEAVE(performLetSubstitutions); return let; } -static LamLetRec *performLetRecSubstitutions(LamLetRec *letrec, TpmcSubstitutionTable - *substitutions) { +static LamLetRec *performLetRecSubstitutions(LamLetRec *letrec, + SymbolMap *substitutions) { ENTER(performLetRecSubstitutions); letrec->bindings = performBindingsSubstitutions(letrec->bindings, substitutions); @@ -237,8 +223,8 @@ static LamLetRec *performLetRecSubstitutions(LamLetRec *letrec, TpmcSubstitution return letrec; } -static LamLetStar *performLetStarSubstitutions(LamLetStar *letStar, TpmcSubstitutionTable - *substitutions) { +static LamLetStar *performLetStarSubstitutions(LamLetStar *letStar, + SymbolMap *substitutions) { ENTER(performLetStarSubstitutions); letStar->bindings = performBindingsSubstitutions(letStar->bindings, substitutions); @@ -247,16 +233,16 @@ static LamLetStar *performLetStarSubstitutions(LamLetStar *letStar, TpmcSubstitu return letStar; } -static LamTypeDefs *performTypeDefsSubstitutions(LamTypeDefs *typeDefs, TpmcSubstitutionTable - *substitutions) { +static LamTypeDefs *performTypeDefsSubstitutions(LamTypeDefs *typeDefs, + SymbolMap *substitutions) { ENTER(performTypeDefsSubstitutions); typeDefs->body = lamPerformSubstitutions(typeDefs->body, substitutions); LEAVE(performTypeDefsSubstitutions); return typeDefs; } -static LamMatchList *performCaseSubstitutions(LamMatchList *cases, TpmcSubstitutionTable - *substitutions) { +static LamMatchList *performCaseSubstitutions(LamMatchList *cases, + SymbolMap *substitutions) { ENTER(performCaseSubstitutions); if (cases == NULL) { LEAVE(performCaseSubstitutions); @@ -268,8 +254,8 @@ static LamMatchList *performCaseSubstitutions(LamMatchList *cases, TpmcSubstitut return cases; } -static LamMatch *performMatchSubstitutions(LamMatch *match, TpmcSubstitutionTable - *substitutions) { +static LamMatch *performMatchSubstitutions(LamMatch *match, + SymbolMap *substitutions) { ENTER(performMatchSubstitutions); match->index = lamPerformSubstitutions(match->index, substitutions); match->cases = performCaseSubstitutions(match->cases, substitutions); @@ -277,8 +263,7 @@ static LamMatch *performMatchSubstitutions(LamMatch *match, TpmcSubstitutionTabl return match; } -static LamAmb *performAmbSubstitutions(LamAmb *amb, - TpmcSubstitutionTable *substitutions) { +static LamAmb *performAmbSubstitutions(LamAmb *amb, SymbolMap *substitutions) { ENTER(performAmbSubstitutions); amb->left = lamPerformSubstitutions(amb->left, substitutions); amb->right = lamPerformSubstitutions(amb->right, substitutions); @@ -286,9 +271,9 @@ static LamAmb *performAmbSubstitutions(LamAmb *amb, return amb; } -static LamIntCondCases *performIntCondCaseSubstitutions(LamIntCondCases - *cases, TpmcSubstitutionTable - *substitutions) { +static LamIntCondCases * +performIntCondCaseSubstitutions(LamIntCondCases *cases, + SymbolMap *substitutions) { ENTER(performIntCondCaseSubstitutions); if (cases == NULL) { LEAVE(performIntCondCaseSubstitutions); @@ -300,50 +285,48 @@ static LamIntCondCases *performIntCondCaseSubstitutions(LamIntCondCases return cases; } -static LamCharCondCases *performCharCondCaseSubstitutions(LamCharCondCases - *cases, TpmcSubstitutionTable - *substitutions) { +static LamCharCondCases * +performCharCondCaseSubstitutions(LamCharCondCases *cases, + SymbolMap *substitutions) { ENTER(performCharCondCaseSubstitutions); if (cases == NULL) { LEAVE(performCharCondCaseSubstitutions); return NULL; } cases->body = lamPerformSubstitutions(cases->body, substitutions); - cases->next = - performCharCondCaseSubstitutions(cases->next, substitutions); + cases->next = performCharCondCaseSubstitutions(cases->next, substitutions); LEAVE(performCharCondCaseSubstitutions); return cases; } -static LamCondCases *performCondCaseSubstitutions(LamCondCases *cases, TpmcSubstitutionTable - *substitutions) { +static LamCondCases *performCondCaseSubstitutions(LamCondCases *cases, + SymbolMap *substitutions) { ENTER(performCondCaseSubstitutions); if (cases == NULL) { LEAVE(performCondCaseSubstitutions); return NULL; } switch (cases->type) { - case LAMCONDCASES_TYPE_INTEGERS: - setLamCondCases_Integers(cases, - performIntCondCaseSubstitutions(getLamCondCases_Integers(cases), - substitutions)); - break; - case LAMCONDCASES_TYPE_CHARACTERS: - setLamCondCases_Characters(cases, - performCharCondCaseSubstitutions(getLamCondCases_Characters(cases), - substitutions)); - break; - default: - cant_happen - ("unrecognised type %d in performCondCaseSubstitutions", - cases->type); + case LAMCONDCASES_TYPE_INTEGERS: + setLamCondCases_Integers( + cases, performIntCondCaseSubstitutions( + getLamCondCases_Integers(cases), substitutions)); + break; + case LAMCONDCASES_TYPE_CHARACTERS: + setLamCondCases_Characters( + cases, performCharCondCaseSubstitutions( + getLamCondCases_Characters(cases), substitutions)); + break; + default: + cant_happen("unrecognised type %d in performCondCaseSubstitutions", + cases->type); } LEAVE(performCondCaseSubstitutions); return cases; } -static LamCond *performCondSubstitutions(LamCond *cond, TpmcSubstitutionTable - *substitutions) { +static LamCond *performCondSubstitutions(LamCond *cond, + SymbolMap *substitutions) { ENTER(performCondSubstitutions); cond->value = lamPerformSubstitutions(cond->value, substitutions); cond->cases = performCondCaseSubstitutions(cond->cases, substitutions); @@ -351,115 +334,119 @@ static LamCond *performCondSubstitutions(LamCond *cond, TpmcSubstitutionTable return cond; } -LamExp *lamPerformSubstitutions(LamExp *exp, - TpmcSubstitutionTable *substitutions) { +LamExp *lamPerformSubstitutions(LamExp *exp, SymbolMap *substitutions) { ENTER(lamPerformSubstitutions); if (exp != NULL) { switch (exp->type) { - case LAMEXP_TYPE_BIGINTEGER: - case LAMEXP_TYPE_STDINT: - case LAMEXP_TYPE_CHARACTER: - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_CONSTANT: - case LAMEXP_TYPE_CONSTRUCTOR: - break; - case LAMEXP_TYPE_LAM: - setLamExp_Lam(exp, - performLamSubstitutions(getLamExp_Lam(exp), substitutions)); - break; - case LAMEXP_TYPE_VAR: - setLamExp_Var(exp, - performVarSubstitutions(getLamExp_Var(exp), substitutions)); - break; - case LAMEXP_TYPE_PRIM: - setLamExp_Prim(exp, - performPrimSubstitutions(getLamExp_Prim(exp), substitutions)); - break; - case LAMEXP_TYPE_SEQUENCE: - setLamExp_Sequence(exp, - performSequenceSubstitutions(getLamExp_Sequence(exp), substitutions)); - break; - case LAMEXP_TYPE_MAKEVEC: - setLamExp_MakeVec(exp, - performMakeVecSubstitutions(getLamExp_MakeVec(exp), substitutions)); - break; - case LAMEXP_TYPE_DECONSTRUCT: - setLamExp_Deconstruct(exp, - performDeconstructSubstitutions(getLamExp_Deconstruct(exp), - substitutions)); - break; - case LAMEXP_TYPE_CONSTRUCT: - setLamExp_Construct(exp, - performConstructSubstitutions(getLamExp_Construct(exp), + case LAMEXP_TYPE_BIGINTEGER: + case LAMEXP_TYPE_STDINT: + case LAMEXP_TYPE_CHARACTER: + case LAMEXP_TYPE_BACK: + case LAMEXP_TYPE_ERROR: + case LAMEXP_TYPE_CONSTANT: + case LAMEXP_TYPE_CONSTRUCTOR: + break; + case LAMEXP_TYPE_LAM: + setLamExp_Lam(exp, performLamSubstitutions(getLamExp_Lam(exp), + substitutions)); + break; + case LAMEXP_TYPE_VAR: + setLamExp_Var(exp, performVarSubstitutions(getLamExp_Var(exp), + substitutions)); + break; + case LAMEXP_TYPE_PRIM: + setLamExp_Prim(exp, performPrimSubstitutions(getLamExp_Prim(exp), + substitutions)); + break; + case LAMEXP_TYPE_SEQUENCE: + setLamExp_Sequence( + exp, performSequenceSubstitutions(getLamExp_Sequence(exp), substitutions)); - break; - case LAMEXP_TYPE_TAG: - setLamExp_Tag(exp, - lamPerformSubstitutions(getLamExp_Tag(exp), substitutions)); - break; - case LAMEXP_TYPE_APPLY: - setLamExp_Apply(exp, - performApplySubstitutions(getLamExp_Apply(exp), substitutions)); - break; - case LAMEXP_TYPE_IFF: - setLamExp_Iff(exp, - performIffSubstitutions(getLamExp_Iff(exp), substitutions)); - break; - case LAMEXP_TYPE_COND: - setLamExp_Cond(exp, - performCondSubstitutions(getLamExp_Cond(exp), substitutions)); - break; - case LAMEXP_TYPE_CALLCC: - setLamExp_CallCC(exp, - lamPerformSubstitutions(getLamExp_CallCC(exp), substitutions)); - break; - case LAMEXP_TYPE_LET: - setLamExp_Let(exp, - performLetSubstitutions(getLamExp_Let(exp), substitutions)); - break; - case LAMEXP_TYPE_LETREC: - setLamExp_LetRec(exp, - performLetRecSubstitutions(getLamExp_LetRec(exp), substitutions)); - break; - case LAMEXP_TYPE_LETSTAR: - setLamExp_LetStar(exp, - performLetStarSubstitutions(getLamExp_LetStar(exp), substitutions)); - break; - case LAMEXP_TYPE_TYPEDEFS: - setLamExp_TypeDefs(exp, - performTypeDefsSubstitutions(getLamExp_TypeDefs(exp), - substitutions)); - break; - case LAMEXP_TYPE_MATCH: - setLamExp_Match(exp, - performMatchSubstitutions(getLamExp_Match(exp), substitutions)); - break; - case LAMEXP_TYPE_AMB: - setLamExp_Amb(exp, - performAmbSubstitutions(getLamExp_Amb(exp), substitutions)); - break; - case LAMEXP_TYPE_MAKETUPLE: - setLamExp_MakeTuple(exp, - performArgsSubstitutions(getLamExp_MakeTuple(exp), substitutions)); - break; - case LAMEXP_TYPE_TUPLEINDEX: - setLamExp_TupleIndex(exp, - performTupleIndexSubstitutions(getLamExp_TupleIndex(exp), substitutions)); - break; - case LAMEXP_TYPE_PRINT: - setLamExp_Print(exp, performPrintSubstitutions(getLamExp_Print(exp), substitutions)); - break; - case LAMEXP_TYPE_LOOKUP: - setLamExp_LookUp(exp, performLookUpSubstitutions(getLamExp_LookUp(exp), substitutions)); - break; - case LAMEXP_TYPE_TYPEOF: - setLamExp_TypeOf(exp, - performTypeOfSubstitutions(getLamExp_TypeOf(exp), substitutions)); - break; - default: - cant_happen - ("unrecognized LamExp type %s", lamExpTypeName(exp->type)); + break; + case LAMEXP_TYPE_MAKEVEC: + setLamExp_MakeVec(exp, performMakeVecSubstitutions( + getLamExp_MakeVec(exp), substitutions)); + break; + case LAMEXP_TYPE_DECONSTRUCT: + setLamExp_Deconstruct( + exp, performDeconstructSubstitutions(getLamExp_Deconstruct(exp), + substitutions)); + break; + case LAMEXP_TYPE_CONSTRUCT: + setLamExp_Construct( + exp, performConstructSubstitutions(getLamExp_Construct(exp), + substitutions)); + break; + case LAMEXP_TYPE_TAG: + setLamExp_Tag(exp, lamPerformSubstitutions(getLamExp_Tag(exp), + substitutions)); + break; + case LAMEXP_TYPE_APPLY: + setLamExp_Apply(exp, performApplySubstitutions(getLamExp_Apply(exp), + substitutions)); + break; + case LAMEXP_TYPE_IFF: + setLamExp_Iff(exp, performIffSubstitutions(getLamExp_Iff(exp), + substitutions)); + break; + case LAMEXP_TYPE_COND: + setLamExp_Cond(exp, performCondSubstitutions(getLamExp_Cond(exp), + substitutions)); + break; + case LAMEXP_TYPE_CALLCC: + setLamExp_CallCC(exp, lamPerformSubstitutions(getLamExp_CallCC(exp), + substitutions)); + break; + case LAMEXP_TYPE_LET: + setLamExp_Let(exp, performLetSubstitutions(getLamExp_Let(exp), + substitutions)); + break; + case LAMEXP_TYPE_LETREC: + setLamExp_LetRec(exp, performLetRecSubstitutions( + getLamExp_LetRec(exp), substitutions)); + break; + case LAMEXP_TYPE_LETSTAR: + setLamExp_LetStar(exp, performLetStarSubstitutions( + getLamExp_LetStar(exp), substitutions)); + break; + case LAMEXP_TYPE_TYPEDEFS: + setLamExp_TypeDefs( + exp, performTypeDefsSubstitutions(getLamExp_TypeDefs(exp), + substitutions)); + break; + case LAMEXP_TYPE_MATCH: + setLamExp_Match(exp, performMatchSubstitutions(getLamExp_Match(exp), + substitutions)); + break; + case LAMEXP_TYPE_AMB: + setLamExp_Amb(exp, performAmbSubstitutions(getLamExp_Amb(exp), + substitutions)); + break; + case LAMEXP_TYPE_MAKETUPLE: + setLamExp_MakeTuple( + exp, performArgsSubstitutions(getLamExp_MakeTuple(exp), + substitutions)); + break; + case LAMEXP_TYPE_TUPLEINDEX: + setLamExp_TupleIndex( + exp, performTupleIndexSubstitutions(getLamExp_TupleIndex(exp), + substitutions)); + break; + case LAMEXP_TYPE_PRINT: + setLamExp_Print(exp, performPrintSubstitutions(getLamExp_Print(exp), + substitutions)); + break; + case LAMEXP_TYPE_LOOKUP: + setLamExp_LookUp(exp, performLookUpSubstitutions( + getLamExp_LookUp(exp), substitutions)); + break; + case LAMEXP_TYPE_TYPEOF: + setLamExp_TypeOf(exp, performTypeOfSubstitutions( + getLamExp_TypeOf(exp), substitutions)); + break; + default: + cant_happen("unrecognized LamExp type %s", + lamExpTypeName(exp->type)); } } LEAVE(lamPerformSubstitutions); diff --git a/src/lambda_substitution.h b/src/lambda_substitution.h index 5e65ede3..6debd915 100644 --- a/src/lambda_substitution.h +++ b/src/lambda_substitution.h @@ -1,5 +1,5 @@ #ifndef cekf_lambda_substitution_h -# define cekf_lambda_substitution_h +#define cekf_lambda_substitution_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,10 +18,9 @@ * along with this program. If not, see . */ -# include "ast.h" -# include "tpmc.h" -# include "lambda.h" +#include "ast.h" +#include "lambda.h" +#include "tpmc.h" -LamExp *lamPerformSubstitutions(LamExp *exp, - TpmcSubstitutionTable *substitutions); +LamExp *lamPerformSubstitutions(LamExp *exp, SymbolMap *substitutions); #endif diff --git a/src/lazy_substitution.c b/src/lazy_substitution.c new file mode 100644 index 00000000..b29c8ed8 --- /dev/null +++ b/src/lazy_substitution.c @@ -0,0 +1,676 @@ +/* + * 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 . + */ + +#include "lazy_substitution.h" +#include "common.h" +#include "lambda_pp.h" +#include "symbol.h" +#include "utils_helper.h" +#include +#include + +#ifdef DEBUG_MACRO_SUBSTITUTE +#include "debugging_on.h" +#else +#include "debugging_off.h" +#endif + +/** + * @brief True if the variable is an argument to the function being converted. + * + * @param var The variable to check. + * @param symbols The set of arguments. + * @return True if the variable is an argument to the function, false otherwise. + */ +static bool isLazyArgument(HashSymbol *var, SymbolSet *symbols) { + return getSymbolSet(symbols, var); +} + +/** + * @brief Perform substitutions on a lambda defined in the body of a + * function. + * + * @param lam The lambda expression to modify. + * @param symbols The current set of arguments. + * @return The modified lambda expression. + */ +static LamExp *performLamSubstitutions(LamLam *lam, SymbolSet *symbols) { + ENTER(performLamSubstitutions); +#if 1 + // fn () { a() } == a + if (lam->args == NULL && lam->exp->type == LAMEXP_TYPE_VAR && + isLazyArgument(getLamExp_Var(lam->exp), symbols)) { + return lam->exp; + } +#endif + SymbolSet *newSymbols = excludeSymbols(lam->args, symbols); + int save = PROTECT(newSymbols); + lam->exp = lamPerformLazySubstitutions(lam->exp, newSymbols); + UNPROTECT(save); + LEAVE(performLamSubstitutions); + return newLamExp_Lam(CPI(lam), lam); +} + +/** + * @brief Collect the names of all letrec bindings in the argument list of + * letrecs. + * + * @param bindings The letrec bindings to collect names from. + * @return A list of variable names for the letrec bindings. + */ +static SymbolList *collectLetRecNames(LamBindings *bindings) { + if (bindings == NULL) { + return NULL; + } + SymbolList *next = collectLetRecNames(bindings->next); + int save = PROTECT(next); + SymbolList *this = newSymbolList(CPI(bindings), bindings->var, next); + UNPROTECT(save); + return this; +} + +/** + * @brief Replaces an argument with an invocation of the argument. + * + * i.e `a` becomes `a()` + * + * This is the second half of the lazy evaluation of functions. + * The first part, `thunkLazyArg` in `lambda_conversion.c`, wraps all the + * unevaluated arguments to lazy functions in thunks. So in the example + * above, `a` is already a thunk at this point. + * + * @param PI The parser information. + * @param exp The variable expression to consider for substitution. + * @param symbols The current set of arguments. + * @return The modified or original expression. + */ +static LamExp *performVarSubstitution(ParserInfo PI, LamExp *exp, + SymbolSet *symbols) { + ENTER(performVarSubstitution); + if (isLazyArgument(getLamExp_Var(exp), symbols)) { + exp = makeLamExp_Apply(PI, exp, NULL); + } + LEAVE(performVarSubstitution); + return exp; +} + +/** + * @brief Recurse into a primitive application performing substitutions on its + * arguments. + * @param prim The primitive application to modify. + * @param symbols The current set of arguments. + * @return The modified primitive application. + */ +static LamPrimApp *performPrimSubstitutions(LamPrimApp *prim, + SymbolSet *symbols) { + ENTER(performPrimSubstitutions); + prim->exp1 = lamPerformLazySubstitutions(prim->exp1, symbols); + prim->exp2 = lamPerformLazySubstitutions(prim->exp2, symbols); + LEAVE(performPrimSubstitutions); + return prim; +} + +/** + * @brief iterates over a sequence, performing substitutions on each element. + * + * @param sequence The sequence to modify. + * @param symbols The current set of arguments. + * @return The modified sequence. + */ +static LamSequence *performSequenceSubstitutions(LamSequence *sequence, + SymbolSet *symbols) { + ENTER(performSequenceSubstitutions); + if (sequence == NULL) { + LEAVE(performSequenceSubstitutions); + return NULL; + } + sequence->next = performSequenceSubstitutions(sequence->next, symbols); + sequence->exp = lamPerformLazySubstitutions(sequence->exp, symbols); + LEAVE(performSequenceSubstitutions); + return sequence; +} + +/** + * @brief iterates over a list of arguments in a function application. + * Performs substitutions on each argument. + * @param list The list of arguments to modify. + * @param symbols The current set of arguments. + * @return The modified list of arguments. + */ +static LamArgs *performArgsSubstitutions(LamArgs *list, SymbolSet *symbols) { + ENTER(performArgsSubstitutions); + if (list == NULL) { + LEAVE(performArgsSubstitutions); + return NULL; + } + list->next = performArgsSubstitutions(list->next, symbols); + list->exp = lamPerformLazySubstitutions(list->exp, symbols); + LEAVE(performArgsSubstitutions); + return list; +} + +/** + * @brief Performs substitutions on the expression in a tuple index. + * @param tupleIndex The tuple index to modify. + * @param symbols The current set of arguments. + * @return The modified tuple index expression. + */ +static LamTupleIndex *performTupleIndexSubstitutions(LamTupleIndex *tupleIndex, + SymbolSet *symbols) { + tupleIndex->exp = lamPerformLazySubstitutions(tupleIndex->exp, symbols); + return tupleIndex; +} + +/** + * @brief Performs substitutions on the argument to a print expression. + * @param print The print expression to modify. + * @param symbols The current set of arguments. + * @return The modified print expression. + */ +static LamPrint *performPrintSubstitutions(LamPrint *print, + SymbolSet *symbols) { + print->exp = lamPerformLazySubstitutions(print->exp, symbols); + print->printer = lamPerformLazySubstitutions(print->printer, symbols); + return print; +} + +/** + * @brief Performs substitutions on a lookUp expression. + * @param lookUp The lookUp expression to modify. + * @param symbols The current set of arguments. + * @return The modified lookUp expression. + */ +static LamLookUp *performLookUpSubstitutions(LamLookUp *lookUp, + SymbolSet *symbols) { + lookUp->exp = lamPerformLazySubstitutions(lookUp->exp, symbols); + return lookUp; +} + +#ifdef NOTDEF +/** + * @brief Performs substitutions on a make vector expression. + * @param makeVec The make vector expression to modify. + * @param symbols The current set of arguments. + * @return The modified make vector expression. + */ +static LamMakeVec *performMakeVecSubstitutions(LamMakeVec *makeVec, + SymbolSet *symbols) { + ENTER(performMakeVecSubstitutions); + makeVec->args = performArgsSubstitutions(makeVec->args, symbols); + LEAVE(performMakeVecSubstitutions); + return makeVec; +} +#endif + +/** + * @brief Performs substitutions on a deconstruct expression. + * @param deconstruct The deconstruct expression to modify. + * @param symbols The current set of arguments. + * @return The modified deconstruct expression. + */ +static LamDeconstruct * +performDeconstructSubstitutions(LamDeconstruct *deconstruct, + SymbolSet *symbols) { + ENTER(performDeconstructSubstitutions); + deconstruct->exp = lamPerformLazySubstitutions(deconstruct->exp, symbols); + LEAVE(performDeconstructSubstitutions); + return deconstruct; +} + +/** + * @brief Performs substitutions on a construct expression. + * @param construct The construct expression to modify. + * @param symbols The current set of arguments. + * @return The modified construct expression. + */ +static LamConstruct *performConstructSubstitutions(LamConstruct *construct, + SymbolSet *symbols) { + ENTER(performConstructSubstitutions); + construct->args = performArgsSubstitutions(construct->args, symbols); + LEAVE(performConstructSubstitutions); + return construct; +} + +/** + * @brief Performs substitutions on a function application expression. + * @param apply The function application expression to modify. + * @param symbols The current set of arguments. + * @return The modified function application expression. + */ +static LamApply *performApplySubstitutions(LamApply *apply, + SymbolSet *symbols) { + ENTER(performApplySubstitutions); + apply->function = lamPerformLazySubstitutions(apply->function, symbols); + apply->args = performArgsSubstitutions(apply->args, symbols); + LEAVE(performApplySubstitutions); + return apply; +} + +/** + * @brief Performs substitutions on an if expression. + * @param iff The if expression to modify. + * @param symbols The current set of arguments. + * @return The modified if expression. + */ +static LamIff *performIffSubstitutions(LamIff *iff, SymbolSet *symbols) { + ENTER(performIffSubstitutions); + iff->condition = lamPerformLazySubstitutions(iff->condition, symbols); + iff->consequent = lamPerformLazySubstitutions(iff->consequent, symbols); + iff->alternative = lamPerformLazySubstitutions(iff->alternative, symbols); + LEAVE(performIffSubstitutions); + return iff; +} + +/** + * @brief Performs substitutions on a list of letrec bindings. + * @param let The letrec bindings to modify. + * @param symbols The current set of arguments. + * @return The modified letrec bindings. + */ +static LamBindings *performBindingsSubstitutions(LamBindings *bindings, + SymbolSet *symbols) { + ENTER(performBindingsSubstitutions); + if (bindings == NULL) { + LEAVE(performBindingsSubstitutions); + return NULL; + } + bindings->next = performBindingsSubstitutions(bindings->next, symbols); + bindings->val = lamPerformLazySubstitutions(bindings->val, symbols); + LEAVE(performBindingsSubstitutions); + return bindings; +} + +/** + * @brief Performs substitutions on a list of let bindings. + * @param bindings The let bindings to modify. + * @param symbols The current set of arguments. + * @return The modified let bindings. + */ +static LamBindings *performLetBindingsSubstitutions(LamBindings *bindings, + SymbolSet **symbols) { + ENTER(performLetBindingsSubstitutions); + if (bindings == NULL) { + LEAVE(performLetBindingsSubstitutions); + return NULL; + } + bindings->val = lamPerformLazySubstitutions(bindings->val, *symbols); + bindings->next = performLetBindingsSubstitutions(bindings->next, symbols); + // exclude *after* performing the other substitutions + if (isLazyArgument(bindings->var, *symbols)) { + *symbols = excludeSymbol(bindings->var, *symbols); + PROTECT(*symbols); // caller will UNPROTECT + } + LEAVE(performLetBindingsSubstitutions); + return bindings; +} + +/** + * @brief Performs substitutions on a list of let* bindings. + * @param bindings The let bindings to modify. + * @param symbols The current set of arguments. + * @return The modified let bindings. + */ +static LamBindings *performLetStarBindingsSubstitutions(LamBindings *bindings, + SymbolSet **symbols) { + ENTER(performLetStarBindingsSubstitutions); + if (bindings == NULL) { + LEAVE(performLetStarBindingsSubstitutions); + return NULL; + } + if (isLazyArgument(bindings->var, *symbols)) { + *symbols = excludeSymbol(bindings->var, *symbols); + PROTECT(*symbols); // caller will UNPROTECT + } + bindings->val = lamPerformLazySubstitutions(bindings->val, *symbols); + bindings->next = + performLetStarBindingsSubstitutions(bindings->next, symbols); + LEAVE(performLetStarBindingsSubstitutions); + return bindings; +} + +/** + * @brief Performs substitutions on a let expression. + * @param let The let expression to modify. + * @param symbols The current set of arguments. + * @return The modified let expression. + */ +static LamLet *performLetSubstitutions(LamLet *let, SymbolSet *symbols) { + ENTER(performLetSubstitutions); + SymbolSet *remaining = copySymbolSet(symbols); + int save = PROTECT(remaining); + let->bindings = performLetBindingsSubstitutions(let->bindings, &remaining); + let->body = lamPerformLazySubstitutions(let->body, remaining); + UNPROTECT(save); + LEAVE(performLetSubstitutions); + return let; +} + +/** + * @brief Performs substitutions on a let* expression. + * @param let The let expression to modify. + * @param symbols The current set of arguments. + * @return The modified let expression. + */ +static LamLetStar *performLetStarSubstitutions(LamLetStar *let, + SymbolSet *symbols) { + ENTER(performLetStarSubstitutions); + SymbolSet *remaining = copySymbolSet(symbols); + int save = PROTECT(remaining); + let->bindings = + performLetStarBindingsSubstitutions(let->bindings, &remaining); + let->body = lamPerformLazySubstitutions(let->body, remaining); + UNPROTECT(save); + LEAVE(performLetStarSubstitutions); + return let; +} + +/** + * @brief Performs substitutions on a letrec expression. + * + * Arranges to exclude *all* letrec bindings from the list of arguments + * before recursing into the letrec bodies. + * + * @param letrec The letrec expression to modify. + * @param symbols The current set of arguments. + * @return The modified letrec expression. + */ +static LamLetRec *performLetRecSubstitutions(LamLetRec *letrec, + SymbolSet *symbols) { + ENTER(performLetRecSubstitutions); + SymbolList *names = collectLetRecNames(letrec->bindings); + int save = PROTECT(names); + if (anySymbolInSet(names, symbols)) { + symbols = excludeSymbols(names, symbols); + PROTECT(symbols); + } + letrec->bindings = performBindingsSubstitutions(letrec->bindings, symbols); + letrec->body = lamPerformLazySubstitutions(letrec->body, symbols); + LEAVE(performLetRecSubstitutions); + UNPROTECT(save); + return letrec; +} + +/** + * @brief Performs substitutions on the body of a typedef. + * @param typeDefs The typedef to modify. + * @param symbols The current set of arguments. + * @return The modified typedef. + */ +static LamTypeDefs *performTypeDefsSubstitutions(LamTypeDefs *typeDefs, + SymbolSet *symbols) { + ENTER(performTypeDefsSubstitutions); + typeDefs->body = lamPerformLazySubstitutions(typeDefs->body, symbols); + LEAVE(performTypeDefsSubstitutions); + return typeDefs; +} + +/** + * @brief Performs substitutions on the bodies of a case expression. + * @param cases The case expression to modify. + * @param symbols The current set of arguments. + * @return The modified case expression. + */ +static LamMatchList *performCaseSubstitutions(LamMatchList *cases, + SymbolSet *symbols) { + ENTER(performCaseSubstitutions); + if (cases == NULL) { + LEAVE(performCaseSubstitutions); + return NULL; + } + cases->next = performCaseSubstitutions(cases->next, symbols); + cases->body = lamPerformLazySubstitutions(cases->body, symbols); + LEAVE(performCaseSubstitutions); + return cases; +} + +/** + * @brief Performs substitutions on the cases of a match expression. + * @param match The match expression to modify. + * @param symbols The current set of arguments. + * @return The modified match expression. + */ +static LamMatch *performMatchSubstitutions(LamMatch *match, + SymbolSet *symbols) { + ENTER(performMatchSubstitutions); + match->index = lamPerformLazySubstitutions(match->index, symbols); + match->cases = performCaseSubstitutions(match->cases, symbols); + LEAVE(performMatchSubstitutions); + return match; +} + +/** + * @brief Performs substitutions on an amb (ambivalent) expression. + * @param amb The amb expression to modify. + * @param symbols The current set of arguments. + * @return The modified amb expression. + */ +static LamAmb *performAmbSubstitutions(LamAmb *amb, SymbolSet *symbols) { + ENTER(performAmbSubstitutions); + amb->left = lamPerformLazySubstitutions(amb->left, symbols); + amb->right = lamPerformLazySubstitutions(amb->right, symbols); + LEAVE(performAmbSubstitutions); + return amb; +} + +/** + * @brief Performs substitutions on integer conditional cases. + * @param cases The integer conditional cases to modify. + * @param symbols The current set of arguments. + * @return The modified integer conditional cases. + */ +static LamIntCondCases *performIntCondCaseSubstitutions(LamIntCondCases *cases, + SymbolSet *symbols) { + ENTER(performIntCondCaseSubstitutions); + if (cases == NULL) { + LEAVE(performIntCondCaseSubstitutions); + return NULL; + } + cases->body = lamPerformLazySubstitutions(cases->body, symbols); + cases->next = performIntCondCaseSubstitutions(cases->next, symbols); + LEAVE(performIntCondCaseSubstitutions); + return cases; +} + +/** + * @brief Performs substitutions on character conditional cases. + * @param cases The character conditional cases to modify. + * @param symbols The current set of arguments. + * @return The modified character conditional cases. + */ +static LamCharCondCases * +performCharCondCaseSubstitutions(LamCharCondCases *cases, SymbolSet *symbols) { + ENTER(performCharCondCaseSubstitutions); + if (cases == NULL) { + LEAVE(performCharCondCaseSubstitutions); + return NULL; + } + cases->body = lamPerformLazySubstitutions(cases->body, symbols); + cases->next = performCharCondCaseSubstitutions(cases->next, symbols); + LEAVE(performCharCondCaseSubstitutions); + return cases; +} + +/** + * @brief Performs substitutions on conditional cases. + * + * Switches between char and int conditional cases appropriately. + * + * @param cases The conditional cases to modify. + * @param symbols The current set of arguments. + * @return The modified conditional cases. + */ +static LamCondCases *performCondCaseSubstitutions(LamCondCases *cases, + SymbolSet *symbols) { + ENTER(performCondCaseSubstitutions); + if (cases == NULL) { + LEAVE(performCondCaseSubstitutions); + return NULL; + } + switch (cases->type) { + case LAMCONDCASES_TYPE_INTEGERS: + setLamCondCases_Integers(cases, + performIntCondCaseSubstitutions( + getLamCondCases_Integers(cases), symbols)); + break; + case LAMCONDCASES_TYPE_CHARACTERS: + setLamCondCases_Characters( + cases, performCharCondCaseSubstitutions( + getLamCondCases_Characters(cases), symbols)); + break; + default: + cant_happen("unrecognised type %d in performCondCaseSubstitutions", + cases->type); + } + LEAVE(performCondCaseSubstitutions); + return cases; +} + +/** + * @brief Performs substitutions on a cond expression. + * @param cond The conditional expression to modify. + * @param symbols The current set of arguments. + * @return The modified conditional expression. + */ +static LamCond *performCondSubstitutions(LamCond *cond, SymbolSet *symbols) { + ENTER(performCondSubstitutions); + cond->value = lamPerformLazySubstitutions(cond->value, symbols); + cond->cases = performCondCaseSubstitutions(cond->cases, symbols); + LEAVE(performCondSubstitutions); + return cond; +} + +/** + * @brief Performs substitutions on a lambda expression. + * + * When called externally, the `exp` is the body of the function + * and the `symbols` table contains the arguments to the function. + * + * @param exp The lambda expression to modify. + * @param symbols The set of arguments. + * @return The modified lambda expression. + */ +LamExp *lamPerformLazySubstitutions(LamExp *exp, SymbolSet *symbols) { + ENTER(lamPerformLazySubstitutions); + // ppLamExp(exp); + // eprintf("\n"); + if (exp != NULL) { + switch (exp->type) { + case LAMEXP_TYPE_BIGINTEGER: + case LAMEXP_TYPE_STDINT: + case LAMEXP_TYPE_CHARACTER: + case LAMEXP_TYPE_BACK: + case LAMEXP_TYPE_ERROR: + case LAMEXP_TYPE_CONSTANT: + case LAMEXP_TYPE_CONSTRUCTOR: + break; + case LAMEXP_TYPE_LAM: + exp = performLamSubstitutions(getLamExp_Lam(exp), symbols); + break; + case LAMEXP_TYPE_VAR: + exp = performVarSubstitution(CPI(exp), exp, symbols); + break; + case LAMEXP_TYPE_PRIM: + setLamExp_Prim( + exp, performPrimSubstitutions(getLamExp_Prim(exp), symbols)); + break; + case LAMEXP_TYPE_SEQUENCE: + setLamExp_Sequence(exp, performSequenceSubstitutions( + getLamExp_Sequence(exp), symbols)); + break; +#ifdef NOTDEF + case LAMEXP_TYPE_MAKEVEC: + setLamExp_MakeVec(exp, performMakeVecSubstitutions( + getLamExp_MakeVec(exp), symbols)); + break; +#endif + case LAMEXP_TYPE_DECONSTRUCT: + setLamExp_Deconstruct( + exp, performDeconstructSubstitutions(getLamExp_Deconstruct(exp), + symbols)); + break; + case LAMEXP_TYPE_CONSTRUCT: + setLamExp_Construct(exp, performConstructSubstitutions( + getLamExp_Construct(exp), symbols)); + break; + case LAMEXP_TYPE_TAG: + setLamExp_Tag( + exp, lamPerformLazySubstitutions(getLamExp_Tag(exp), symbols)); + break; + case LAMEXP_TYPE_APPLY: + setLamExp_Apply( + exp, performApplySubstitutions(getLamExp_Apply(exp), symbols)); + break; + case LAMEXP_TYPE_IFF: + setLamExp_Iff(exp, + performIffSubstitutions(getLamExp_Iff(exp), symbols)); + break; + case LAMEXP_TYPE_COND: + setLamExp_Cond( + exp, performCondSubstitutions(getLamExp_Cond(exp), symbols)); + break; + case LAMEXP_TYPE_CALLCC: + setLamExp_CallCC(exp, lamPerformLazySubstitutions( + getLamExp_CallCC(exp), symbols)); + break; + case LAMEXP_TYPE_LET: + setLamExp_Let(exp, + performLetSubstitutions(getLamExp_Let(exp), symbols)); + break; + case LAMEXP_TYPE_LETREC: + setLamExp_LetRec(exp, performLetRecSubstitutions( + getLamExp_LetRec(exp), symbols)); + break; + case LAMEXP_TYPE_LETSTAR: + setLamExp_LetStar(exp, performLetStarSubstitutions( + getLamExp_LetStar(exp), symbols)); + break; + case LAMEXP_TYPE_TYPEDEFS: + setLamExp_TypeDefs(exp, performTypeDefsSubstitutions( + getLamExp_TypeDefs(exp), symbols)); + break; + case LAMEXP_TYPE_MATCH: + setLamExp_Match( + exp, performMatchSubstitutions(getLamExp_Match(exp), symbols)); + break; + case LAMEXP_TYPE_AMB: + setLamExp_Amb(exp, + performAmbSubstitutions(getLamExp_Amb(exp), symbols)); + break; + case LAMEXP_TYPE_MAKETUPLE: + setLamExp_MakeTuple(exp, performArgsSubstitutions( + getLamExp_MakeTuple(exp), symbols)); + break; + case LAMEXP_TYPE_TUPLEINDEX: + setLamExp_TupleIndex(exp, performTupleIndexSubstitutions( + getLamExp_TupleIndex(exp), symbols)); + break; + case LAMEXP_TYPE_PRINT: + setLamExp_Print( + exp, performPrintSubstitutions(getLamExp_Print(exp), symbols)); + break; + case LAMEXP_TYPE_LOOKUP: + setLamExp_LookUp(exp, performLookUpSubstitutions( + getLamExp_LookUp(exp), symbols)); + break; + default: + cant_happen("unrecognized %s", lamExpTypeName(exp->type)); + } + } + LEAVE(lamPerformLazySubstitutions); + return exp; +} diff --git a/src/macro_substitution.h b/src/lazy_substitution.h similarity index 80% rename from src/macro_substitution.h rename to src/lazy_substitution.h index aa456c42..53848c17 100644 --- a/src/macro_substitution.h +++ b/src/lazy_substitution.h @@ -1,24 +1,25 @@ -#ifndef cekf_macro_substitution_h -# define cekf_macro_substitution_h +#ifndef cekf_lazy_substitution_h +#define cekf_lazy_substitution_h /* * 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 . */ -# include "lambda.h" +#include "lambda.h" +#include "utils.h" -LamExp *lamPerformMacroSubstitutions(LamExp *, LamMacroArgsSet *); +LamExp *lamPerformLazySubstitutions(LamExp *, SymbolSet *); #endif diff --git a/src/macro_substitution.c b/src/macro_substitution.c deleted file mode 100644 index f5ba10ba..00000000 --- a/src/macro_substitution.c +++ /dev/null @@ -1,733 +0,0 @@ -/* - * 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 . - */ - - -#include -#include -#include "common.h" -#include "macro_substitution.h" -#include "symbol.h" -#include "lambda_pp.h" - -#ifdef DEBUG_MACRO_SUBSTITUTE -# include "debugging_on.h" -#else -# include "debugging_off.h" -#endif - -static LamMacroArgsSet *excludeSymbols(LamVarList *, LamMacroArgsSet *); - -/** - * @brief True if the variable is an argument to the macro being converted. - * - * @param var The variable to check. - * @param symbols The set of macro arguments. - * @return True if the variable is an argument to the macro, false otherwise. - */ -static bool isMacroArgument(HashSymbol *var, LamMacroArgsSet *symbols) { - return getLamMacroArgsSet(symbols, var); -} - -/** - * @brief Perform macro substitutions on a lambda defined in the body of a macro. - * - * @param lam The lambda expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified lambda expression. - */ -static LamExp *performLamSubstitutions(LamLam *lam, LamMacroArgsSet *symbols) { - ENTER(performLamSubstitutions); -#if 1 - // fn () { a() } == a - if ( lam->args == NULL - && lam->exp->type == LAMEXP_TYPE_VAR - && isMacroArgument(getLamExp_Var(lam->exp), symbols)) { - return lam->exp; - } -#endif - LamMacroArgsSet *newSymbols = excludeSymbols(lam->args, symbols); - int save = PROTECT(newSymbols); - lam->exp = lamPerformMacroSubstitutions(lam->exp, newSymbols); - UNPROTECT(save); - LEAVE(performLamSubstitutions); - return newLamExp_Lam(CPI(lam), lam); -} - -/** - * @brief Check if any variables in the list are macro arguments. - * - * @param vars The list of variables to check. - * @param symbols The current set of macro arguments. - * @return True if any variable is a macro argument, false otherwise. - */ -static bool containsMacroArguments(LamVarList *vars, LamMacroArgsSet *symbols) { - while (vars != NULL) { - if (isMacroArgument(vars->var, symbols)) { - return true; - } - vars = vars->next; - } - return false; -} - -/** - * @brief Exclude a symbol from the set of macro arguments. - * - * @param var The variable to exclude. - * @param symbols The current set of macro arguments. - * @return A new set of macro arguments without the excluded symbol. - */ -static LamMacroArgsSet *excludeSymbol(HashSymbol *var, LamMacroArgsSet *symbols) { - LamMacroArgsSet *new = newLamMacroArgsSet(); - int save = PROTECT(new); - Index i = 0; - HashSymbol *current; - while ((current = iterateLamMacroArgsSet(symbols, &i)) != NULL) { - if (current != var) { - setLamMacroArgsSet(new, current); - } - } - UNPROTECT(save); - return new; -} - -/** - * @brief Copy a set of macro arguments. - * - * @param symbols The current set of macro arguments. - * @return A new set of macro arguments. - */ -static LamMacroArgsSet *copyLamMacroArgsSet(LamMacroArgsSet *symbols) { - LamMacroArgsSet *new = newLamMacroArgsSet(); - int save = PROTECT(new); - Index i = 0; - HashSymbol *current; - while ((current = iterateLamMacroArgsSet(symbols, &i)) != NULL) { - setLamMacroArgsSet(new, current); - } - UNPROTECT(save); - return new; -} - -/** - * @brief Check if a variable is in a list of variables. - * - * @param var The variable to check. - * @param vars The list of variables to search in. - * @return True if the variable is found, false otherwise. - */ -static bool varInVarList(HashSymbol *var, LamVarList *vars) { - while (vars != NULL) { - if (var == vars->var) { - return true; - } - vars = vars->next; - } - return false; -} - -/** - * @brief Exclude a list of variables from the set of macro arguments. - * - * @param vars The list of variables to exclude. - * @param symbols The current set of macro arguments. - * @return A new set of macro arguments without the excluded variables. - */ -static LamMacroArgsSet *excludeSymbols(LamVarList *vars, LamMacroArgsSet *symbols) { - LamMacroArgsSet *new = newLamMacroArgsSet(); - int save = PROTECT(new); - Index i = 0; - HashSymbol *current; - while ((current = iterateLamMacroArgsSet(symbols, &i)) != NULL) { - if (!varInVarList(current, vars)) { - setLamMacroArgsSet(new, current); - } - } - UNPROTECT(save); - return new; -} - -/** - * @brief Collect the names of all letrec bindings in the argument list of letrecs. - * - * @param bindings The letrec bindings to collect names from. - * @return A list of variable names for the letrec bindings. - */ -static LamVarList *collectLetRecNames(LamBindings *bindings) { - if (bindings == NULL) { - return NULL; - } - LamVarList *next = collectLetRecNames(bindings->next); - int save = PROTECT(next); - LamVarList *this = newLamVarList(CPI(bindings), bindings->var, next); - UNPROTECT(save); - return this; -} - -/** - * @brief Replaces a macro argument with an invocation of the argument. - * - * i.e `a` becomes `a()` - * - * This is the second half of the lazy evaluation of macros. - * The first part, `thunkMacroArg` in `lambda_conversion.c`, wrap all the unevaluated - * arguments to macros in thunks. - * So in the example above, `a` is already a thunk at this point. - * - * @param PI The parser information. - * @param exp The variable expression to consider for substitution. - * @param symbols The current set of macro arguments. - * @return The modified or original expression. - */ -static LamExp *performVarSubstitution(ParserInfo PI, LamExp *exp, LamMacroArgsSet *symbols) { - ENTER(performVarSubstitution); - if (isMacroArgument(getLamExp_Var(exp), symbols)) { - exp = makeLamExp_Apply(PI, exp, NULL); - } - LEAVE(performVarSubstitution); - return exp; -} - -/** - * @brief Recurse into a primitive application performing substitutions on its arguments. - * @param prim The primitive application to modify. - * @param symbols The current set of macro arguments. - * @return The modified primitive application. - */ -static LamPrimApp *performPrimSubstitutions(LamPrimApp *prim, LamMacroArgsSet *symbols) { - ENTER(performPrimSubstitutions); - prim->exp1 = lamPerformMacroSubstitutions(prim->exp1, symbols); - prim->exp2 = lamPerformMacroSubstitutions(prim->exp2, symbols); - LEAVE(performPrimSubstitutions); - return prim; -} - -/** - * @brief iterates over a sequence, performing substitutions on each element. - * - * @param sequence The sequence to modify. - * @param symbols The current set of macro arguments. - * @return The modified sequence. - */ -static LamSequence *performSequenceSubstitutions(LamSequence *sequence, LamMacroArgsSet *symbols) { - ENTER(performSequenceSubstitutions); - if (sequence == NULL) { - LEAVE(performSequenceSubstitutions); - return NULL; - } - sequence->next = - performSequenceSubstitutions(sequence->next, symbols); - sequence->exp = lamPerformMacroSubstitutions(sequence->exp, symbols); - LEAVE(performSequenceSubstitutions); - return sequence; -} - -/** - * @brief iterates over a list of arguments in a function application. - * Performs substitutions on each argument. - * @param list The list of arguments to modify. - * @param symbols The current set of macro arguments. - * @return The modified list of arguments. - */ -static LamArgs *performArgsSubstitutions(LamArgs *list, LamMacroArgsSet *symbols) { - ENTER(performArgsSubstitutions); - if (list == NULL) { - LEAVE(performArgsSubstitutions); - return NULL; - } - list->next = performArgsSubstitutions(list->next, symbols); - list->exp = lamPerformMacroSubstitutions(list->exp, symbols); - LEAVE(performArgsSubstitutions); - return list; -} - -/** - * @brief Performs substitutions on the expression in a tuple index. - * @param tupleIndex The tuple index to modify. - * @param symbols The current set of macro arguments. - * @return The modified tuple index expression. - */ -static LamTupleIndex *performTupleIndexSubstitutions(LamTupleIndex *tupleIndex, LamMacroArgsSet *symbols) { - tupleIndex->exp = lamPerformMacroSubstitutions(tupleIndex->exp, symbols); - return tupleIndex; -} - -/** - * @brief Performs substitutions on the argument to a print expression. - * @param print The print expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified print expression. - */ -static LamPrint *performPrintSubstitutions(LamPrint *print, LamMacroArgsSet *symbols) { - print->exp = lamPerformMacroSubstitutions(print->exp, symbols); - print->printer = lamPerformMacroSubstitutions(print->printer, symbols); - return print; -} - -/** - * @brief Performs macro substitutions on a lookUp expression. - * @param lookUp The lookUp expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified lookUp expression. - */ -static LamLookUp *performLookUpSubstitutions(LamLookUp *lookUp, LamMacroArgsSet *symbols) { - lookUp->exp = lamPerformMacroSubstitutions(lookUp->exp, symbols); - return lookUp; -} - -#ifdef NOTDEF -/** - * @brief Performs macro substitutions on a make vector expression. - * @param makeVec The make vector expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified make vector expression. - */ -static LamMakeVec *performMakeVecSubstitutions(LamMakeVec *makeVec, LamMacroArgsSet *symbols) { - ENTER(performMakeVecSubstitutions); - makeVec->args = performArgsSubstitutions(makeVec->args, symbols); - LEAVE(performMakeVecSubstitutions); - return makeVec; -} -#endif - -/** - * @brief Performs macro substitutions on a deconstruct expression. - * @param deconstruct The deconstruct expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified deconstruct expression. - */ -static LamDeconstruct *performDeconstructSubstitutions(LamDeconstruct *deconstruct, LamMacroArgsSet *symbols) { - ENTER(performDeconstructSubstitutions); - deconstruct->exp = - lamPerformMacroSubstitutions(deconstruct->exp, symbols); - LEAVE(performDeconstructSubstitutions); - return deconstruct; -} - -/** - * @brief Performs macro substitutions on a construct expression. - * @param construct The construct expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified construct expression. - */ -static LamConstruct *performConstructSubstitutions(LamConstruct *construct, LamMacroArgsSet *symbols) { - ENTER(performConstructSubstitutions); - construct->args = - performArgsSubstitutions(construct->args, symbols); - LEAVE(performConstructSubstitutions); - return construct; -} - -/** - * @brief Performs macro substitutions on a function application expression. - * @param apply The function application expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified function application expression. - */ -static LamApply *performApplySubstitutions(LamApply *apply, LamMacroArgsSet *symbols) { - ENTER(performApplySubstitutions); - apply->function = lamPerformMacroSubstitutions(apply->function, symbols); - apply->args = performArgsSubstitutions(apply->args, symbols); - LEAVE(performApplySubstitutions); - return apply; -} - -/** - * @brief Performs macro substitutions on an if expression. - * @param iff The if expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified if expression. - */ -static LamIff *performIffSubstitutions(LamIff *iff, LamMacroArgsSet *symbols) { - ENTER(performIffSubstitutions); - iff->condition = lamPerformMacroSubstitutions(iff->condition, symbols); - iff->consequent = lamPerformMacroSubstitutions(iff->consequent, symbols); - iff->alternative = - lamPerformMacroSubstitutions(iff->alternative, symbols); - LEAVE(performIffSubstitutions); - return iff; -} - -/** - * @brief Performs macro substitutions on a list of letrec bindings. - * @param let The letrec bindings to modify. - * @param symbols The current set of macro arguments. - * @return The modified letrec bindings. - */ -static LamBindings *performBindingsSubstitutions(LamBindings *bindings, - LamMacroArgsSet *symbols) { - ENTER(performBindingsSubstitutions); - if (bindings == NULL) { - LEAVE(performBindingsSubstitutions); - return NULL; - } - bindings->next = performBindingsSubstitutions(bindings->next, symbols); - bindings->val = lamPerformMacroSubstitutions(bindings->val, symbols); - LEAVE(performBindingsSubstitutions); - return bindings; -} - -/** - * @brief Performs macro substitutions on a list of let bindings. - * @param bindings The let bindings to modify. - * @param symbols The current set of macro arguments. - * @return The modified let bindings. - */ -static LamBindings *performLetBindingsSubstitutions(LamBindings *bindings, LamMacroArgsSet **symbols) { - ENTER(performLetBindingsSubstitutions); - if (bindings == NULL) { - LEAVE(performLetBindingsSubstitutions); - return NULL; - } - bindings->val = lamPerformMacroSubstitutions(bindings->val, *symbols); - bindings->next = performLetBindingsSubstitutions(bindings->next, symbols); - // exclude *after* performing the other substitutions - if (isMacroArgument(bindings->var, *symbols)) { - *symbols = excludeSymbol(bindings->var, *symbols); - PROTECT(*symbols); // caller will UNPROTECT - } - LEAVE(performLetBindingsSubstitutions); - return bindings; -} - -/** - * @brief Performs macro substitutions on a list of let* bindings. - * @param bindings The let bindings to modify. - * @param symbols The current set of macro arguments. - * @return The modified let bindings. - */ -static LamBindings *performLetStarBindingsSubstitutions(LamBindings *bindings, LamMacroArgsSet **symbols) { - ENTER(performLetStarBindingsSubstitutions); - if (bindings == NULL) { - LEAVE(performLetStarBindingsSubstitutions); - return NULL; - } - if (isMacroArgument(bindings->var, *symbols)) { - *symbols = excludeSymbol(bindings->var, *symbols); - PROTECT(*symbols); // caller will UNPROTECT - } - bindings->val = lamPerformMacroSubstitutions(bindings->val, *symbols); - bindings->next = performLetStarBindingsSubstitutions(bindings->next, symbols); - LEAVE(performLetStarBindingsSubstitutions); - return bindings; -} - -/** - * @brief Performs macro substitutions on a let expression. - * @param let The let expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified let expression. - */ -static LamLet *performLetSubstitutions(LamLet *let, LamMacroArgsSet *symbols) { - ENTER(performLetSubstitutions); - LamMacroArgsSet *remaining = copyLamMacroArgsSet(symbols); - int save = PROTECT(remaining); - let->bindings = performLetBindingsSubstitutions(let->bindings, &remaining); - let->body = lamPerformMacroSubstitutions(let->body, remaining); - UNPROTECT(save); - LEAVE(performLetSubstitutions); - return let; -} - -/** - * @brief Performs macro substitutions on a let* expression. - * @param let The let expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified let expression. - */ -static LamLetStar *performLetStarSubstitutions(LamLetStar *let, LamMacroArgsSet *symbols) { - ENTER(performLetStarSubstitutions); - LamMacroArgsSet *remaining = copyLamMacroArgsSet(symbols); - int save = PROTECT(remaining); - let->bindings = performLetStarBindingsSubstitutions(let->bindings, &remaining); - let->body = lamPerformMacroSubstitutions(let->body, remaining); - UNPROTECT(save); - LEAVE(performLetStarSubstitutions); - return let; -} - -/** - * @brief Performs macro substitutions on a letrec expression. - * - * Arranges to exclude *all* letrec bindings from the list of macro arguments - * before recursing into the letrec bodies. - * - * @param letrec The letrec expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified letrec expression. - */ -static LamLetRec *performLetRecSubstitutions(LamLetRec *letrec, LamMacroArgsSet *symbols) { - ENTER(performLetRecSubstitutions); - LamVarList *names = collectLetRecNames(letrec->bindings); - int save = PROTECT(names); - if (containsMacroArguments(names, symbols)) { - symbols = excludeSymbols(names, symbols); - PROTECT(symbols); - } - letrec->bindings = performBindingsSubstitutions(letrec->bindings, symbols); - letrec->body = lamPerformMacroSubstitutions(letrec->body, symbols); - LEAVE(performLetRecSubstitutions); - UNPROTECT(save); - return letrec; -} - -/** - * @brief Performs macro substitutions on the body of a typedef. - * @param typeDefs The typedef to modify. - * @param symbols The current set of macro arguments. - * @return The modified typedef. - */ -static LamTypeDefs *performTypeDefsSubstitutions(LamTypeDefs *typeDefs, LamMacroArgsSet *symbols) { - ENTER(performTypeDefsSubstitutions); - typeDefs->body = lamPerformMacroSubstitutions(typeDefs->body, symbols); - LEAVE(performTypeDefsSubstitutions); - return typeDefs; -} - -/** - * @brief Performs macro substitutions on the bodies of a case expression. - * @param cases The case expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified case expression. - */ -static LamMatchList *performCaseSubstitutions(LamMatchList *cases, LamMacroArgsSet *symbols) { - ENTER(performCaseSubstitutions); - if (cases == NULL) { - LEAVE(performCaseSubstitutions); - return NULL; - } - cases->next = performCaseSubstitutions(cases->next, symbols); - cases->body = lamPerformMacroSubstitutions(cases->body, symbols); - LEAVE(performCaseSubstitutions); - return cases; -} - -/** - * @brief Performs macro substitutions on the cases of a match expression. - * @param match The match expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified match expression. - */ -static LamMatch *performMatchSubstitutions(LamMatch *match, LamMacroArgsSet *symbols) { - ENTER(performMatchSubstitutions); - match->index = lamPerformMacroSubstitutions(match->index, symbols); - match->cases = performCaseSubstitutions(match->cases, symbols); - LEAVE(performMatchSubstitutions); - return match; -} - -/** - * @brief Performs macro substitutions on an amb (ambivalent) expression. - * @param amb The amb expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified amb expression. - */ -static LamAmb *performAmbSubstitutions(LamAmb *amb, LamMacroArgsSet *symbols) { - ENTER(performAmbSubstitutions); - amb->left = lamPerformMacroSubstitutions(amb->left, symbols); - amb->right = lamPerformMacroSubstitutions(amb->right, symbols); - LEAVE(performAmbSubstitutions); - return amb; -} - -/** - * @brief Performs macro substitutions on integer conditional cases. - * @param cases The integer conditional cases to modify. - * @param symbols The current set of macro arguments. - * @return The modified integer conditional cases. - */ -static LamIntCondCases *performIntCondCaseSubstitutions(LamIntCondCases *cases, - LamMacroArgsSet *symbols) { - ENTER(performIntCondCaseSubstitutions); - if (cases == NULL) { - LEAVE(performIntCondCaseSubstitutions); - return NULL; - } - cases->body = lamPerformMacroSubstitutions(cases->body, symbols); - cases->next = performIntCondCaseSubstitutions(cases->next, symbols); - LEAVE(performIntCondCaseSubstitutions); - return cases; -} - -/** - * @brief Performs macro substitutions on character conditional cases. - * @param cases The character conditional cases to modify. - * @param symbols The current set of macro arguments. - * @return The modified character conditional cases. - */ -static LamCharCondCases *performCharCondCaseSubstitutions(LamCharCondCases *cases, LamMacroArgsSet *symbols) { - ENTER(performCharCondCaseSubstitutions); - if (cases == NULL) { - LEAVE(performCharCondCaseSubstitutions); - return NULL; - } - cases->body = lamPerformMacroSubstitutions(cases->body, symbols); - cases->next = - performCharCondCaseSubstitutions(cases->next, symbols); - LEAVE(performCharCondCaseSubstitutions); - return cases; -} - -/** - * @brief Performs macro substitutions on conditional cases. - * - * Switches between char and int conditional cases appropriately. - * - * @param cases The conditional cases to modify. - * @param symbols The current set of macro arguments. - * @return The modified conditional cases. - */ -static LamCondCases *performCondCaseSubstitutions(LamCondCases *cases, LamMacroArgsSet *symbols) { - ENTER(performCondCaseSubstitutions); - if (cases == NULL) { - LEAVE(performCondCaseSubstitutions); - return NULL; - } - switch (cases->type) { - case LAMCONDCASES_TYPE_INTEGERS: - setLamCondCases_Integers(cases, - performIntCondCaseSubstitutions(getLamCondCases_Integers(cases), - symbols)); - break; - case LAMCONDCASES_TYPE_CHARACTERS: - setLamCondCases_Characters(cases, - performCharCondCaseSubstitutions(getLamCondCases_Characters(cases), - symbols)); - break; - default: - cant_happen - ("unrecognised type %d in performCondCaseSubstitutions", - cases->type); - } - LEAVE(performCondCaseSubstitutions); - return cases; -} - -/** - * @brief Performs macro substitutions on a cond expression. - * @param cond The conditional expression to modify. - * @param symbols The current set of macro arguments. - * @return The modified conditional expression. - */ -static LamCond *performCondSubstitutions(LamCond *cond, LamMacroArgsSet *symbols) { - ENTER(performCondSubstitutions); - cond->value = lamPerformMacroSubstitutions(cond->value, symbols); - cond->cases = performCondCaseSubstitutions(cond->cases, symbols); - LEAVE(performCondSubstitutions); - return cond; -} - -/** - * @brief Performs macro substitutions on a lambda expression. - * - * When called externally, the `exp` is the body of the macro - * and the `symbols` table contains the arguments to the macro. - * - * @param exp The lambda expression to modify. - * @param symbols The set of macro arguments. - * @return The modified lambda expression. - */ -LamExp *lamPerformMacroSubstitutions(LamExp *exp, LamMacroArgsSet *symbols) { - ENTER(lamPerformMacroSubstitutions); - // ppLamExp(exp); - // eprintf("\n"); - if (exp != NULL) { - switch (exp->type) { - case LAMEXP_TYPE_BIGINTEGER: - case LAMEXP_TYPE_STDINT: - case LAMEXP_TYPE_CHARACTER: - case LAMEXP_TYPE_BACK: - case LAMEXP_TYPE_ERROR: - case LAMEXP_TYPE_CONSTANT: - case LAMEXP_TYPE_CONSTRUCTOR: - break; - case LAMEXP_TYPE_LAM: - exp = performLamSubstitutions(getLamExp_Lam(exp), symbols); - break; - case LAMEXP_TYPE_VAR: - exp = performVarSubstitution(CPI(exp), exp, symbols); - break; - case LAMEXP_TYPE_PRIM: - setLamExp_Prim(exp, performPrimSubstitutions(getLamExp_Prim(exp), symbols)); - break; - case LAMEXP_TYPE_SEQUENCE: - setLamExp_Sequence(exp, performSequenceSubstitutions(getLamExp_Sequence(exp), symbols)); - break; -#ifdef NOTDEF - case LAMEXP_TYPE_MAKEVEC: - setLamExp_MakeVec(exp, performMakeVecSubstitutions(getLamExp_MakeVec(exp), symbols)); - break; -#endif - case LAMEXP_TYPE_DECONSTRUCT: - setLamExp_Deconstruct(exp, performDeconstructSubstitutions(getLamExp_Deconstruct(exp), symbols)); - break; - case LAMEXP_TYPE_CONSTRUCT: - setLamExp_Construct(exp, performConstructSubstitutions(getLamExp_Construct(exp), symbols)); - break; - case LAMEXP_TYPE_TAG: - setLamExp_Tag(exp, lamPerformMacroSubstitutions(getLamExp_Tag(exp), symbols)); - break; - case LAMEXP_TYPE_APPLY: - setLamExp_Apply(exp, performApplySubstitutions(getLamExp_Apply(exp), symbols)); - break; - case LAMEXP_TYPE_IFF: - setLamExp_Iff(exp, performIffSubstitutions(getLamExp_Iff(exp), symbols)); - break; - case LAMEXP_TYPE_COND: - setLamExp_Cond(exp, performCondSubstitutions(getLamExp_Cond(exp), symbols)); - break; - case LAMEXP_TYPE_CALLCC: - setLamExp_CallCC(exp, lamPerformMacroSubstitutions(getLamExp_CallCC(exp), symbols)); - break; - case LAMEXP_TYPE_LET: - setLamExp_Let(exp, performLetSubstitutions(getLamExp_Let(exp), symbols)); - break; - case LAMEXP_TYPE_LETREC: - setLamExp_LetRec(exp, performLetRecSubstitutions(getLamExp_LetRec(exp), symbols)); - break; - case LAMEXP_TYPE_LETSTAR: - setLamExp_LetStar(exp, performLetStarSubstitutions(getLamExp_LetStar(exp), symbols)); - break; - case LAMEXP_TYPE_TYPEDEFS: - setLamExp_TypeDefs(exp, performTypeDefsSubstitutions(getLamExp_TypeDefs(exp), symbols)); - break; - case LAMEXP_TYPE_MATCH: - setLamExp_Match(exp, performMatchSubstitutions(getLamExp_Match(exp), symbols)); - break; - case LAMEXP_TYPE_AMB: - setLamExp_Amb(exp, performAmbSubstitutions(getLamExp_Amb(exp), symbols)); - break; - case LAMEXP_TYPE_MAKETUPLE: - setLamExp_MakeTuple(exp, performArgsSubstitutions(getLamExp_MakeTuple(exp), symbols)); - break; - case LAMEXP_TYPE_TUPLEINDEX: - setLamExp_TupleIndex(exp, performTupleIndexSubstitutions(getLamExp_TupleIndex(exp), symbols)); - break; - case LAMEXP_TYPE_PRINT: - setLamExp_Print(exp, performPrintSubstitutions(getLamExp_Print(exp), symbols)); - break; - case LAMEXP_TYPE_LOOKUP: - setLamExp_LookUp(exp, performLookUpSubstitutions(getLamExp_LookUp(exp), symbols)); - break; - default: - cant_happen("unrecognized %s", lamExpTypeName(exp->type)); - } - } - LEAVE(lamPerformMacroSubstitutions); - return exp; -} diff --git a/src/main.c b/src/main.c index 7a1655ad..7e1eb11c 100644 --- a/src/main.c +++ b/src/main.c @@ -15,43 +15,45 @@ * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ +#include +#include +#include #include #include -#include -#include #include -#include -#include "common.h" -#include "ast.h" -#include "ast_debug.h" -#include "lambda_debug.h" -#include "lambda_conversion.h" -#include "lambda_simplification.h" -#include "annotate.h" #include "anf.h" #include "anf_normalize.h" -#include "memory.h" -#include "step.h" -#include "debug.h" #include "anf_pp.h" -#include "bytecode.h" -#include "hash.h" -#include "lambda_pp.h" -#include "anf_normalize.h" -#include "bigint.h" -#include "tc_analyze.h" -#include "tc_debug.h" -#include "tpmc_mermaid.h" +#include "annotate.h" #include "arithmetic.h" +#include "ast.h" +#include "ast_debug.h" +#include "bigint.h" #include "builtins_helper.h" +#include "bytecode.h" +#include "common.h" +#include "debug.h" +#include "hash.h" +#include "init.h" #include "inline.h" +#include "lambda_alphaconvert.h" +#include "lambda_conversion.h" +#include "lambda_debug.h" +#include "lambda_desugar.h" +#include "lambda_pp.h" +#include "lambda_simplification.h" +#include "memory.h" +#include "minlam_pp.h" #include "pratt.h" #include "pratt_parser.h" #include "pratt_scanner.h" -#include "init.h" +#include "step.h" +#include "tc_analyze.h" +#include "tc_debug.h" +#include "tpmc_mermaid.h" +#include "utils.h" #include "wrapper_synthesis.h" -#include "lambda_alphaconvert.h" #ifdef UNIT_TESTS #include "tests.h" #endif @@ -84,32 +86,32 @@ static char *binary_output_file = NULL; static char *binary_input_file = NULL; static char *snippet = NULL; -extern AstStringArray *include_paths; +extern StringArray *include_paths; /** * Report the build mode, i.e. the value of the BUILD_MODE macro when compiled. - * + * * @param prog the program name */ static void report_build_mode(char *prog) { printf("%s - ", prog); #ifdef BUILD_MODE switch (BUILD_MODE) { - case 0: - printf("debug build\n"); - break; - case 1: - printf("test build\n"); - break; - case 2: - printf("production build\n"); - break; - case 3: - printf("coverage build\n"); - break; - default: - printf("unrecognised build\n"); - break; + case 0: + printf("debug build\n"); + break; + case 1: + printf("test build\n"); + break; + case 2: + printf("production build\n"); + break; + case 3: + printf("coverage build\n"); + break; + default: + printf("unrecognised build\n"); + break; } #else printf("unspecified build\n"); @@ -118,44 +120,60 @@ static void report_build_mode(char *prog) { /** * Display command-line usage information and exit. - * + * * @param prog the program name * @param status the exit status */ static void usage(char *prog, int status) { report_build_mode(prog); printf("usage: %s [---] [ [ ...]]\n", prog); - printf("options:\n%s", - " -h\n" - " --help This help.\n" - " --assertions-accumulate Don't exit on the first assertion failure.\n" - " --binary-in= Read byte code from file.\n" - " --binary-out= Write byte code to file.\n" - " -a\n" - " --dump-alpha Display the intermediate code after alpha-conversion.\n" - " -a\n" - " --dump-alpha= Display the intermediate code after alpha-conversion.\n" - " --dump-anf Display the generated ANF.\n" - " --dump-ast Display the parsed AST before lambda conversion.\n" - " --dump-bytecode Dump the generated bytecode.\n" - " --dump-inline Display the intermediate code after inlining.\n" - " -l\n" - " --dump-lambda Display all the intermediate code.\n" - " -l\n" - " --dump-lambda= Display the intermediate code for the function.\n" - " -m \n" - " --dump-tpmc= Dump a mermaid graph of the TPMC state table.\n" - " -e\n" - " --exec= Execute the snippet of code directly\n" - " -i\n" - " --include= Add dir to the list of directories to be searched.\n" - " --parse-only Stop after parsing to enable parser-only profiling.\n" - " --report Report statistics.\n" + printf( + "options:\n%s", + " -h\n" + " --help This help.\n" + " --assertions-accumulate Don't exit on the first assertion " + "failure.\n" + " --binary-in= Read byte code from file.\n" + " --binary-out= Write byte code to file.\n" + " -a\n" + " --dump-alpha Display the intermediate code after " + "alpha-conversion.\n" + " -a\n" + " --dump-alpha= Display the intermediate code after " + "alpha-conversion.\n" + " --dump-anf Display the generated ANF.\n" + " --dump-ast Display the parsed AST before lambda " + "conversion.\n" + " --dump-bytecode Dump the generated bytecode.\n" + " -d\n" + " --dump-desugared Display the intermediate code after " + "desugaring.\n" + " -d\n" + " --dump-desugared= Display the intermediate code after " + "desugaring.\n" + " --dump-inline Display the intermediate code after " + "inlining.\n" + " -l\n" + " --dump-lambda Display all the intermediate code.\n" + " -l\n" + " --dump-lambda= Display the intermediate code for the " + "function.\n" + " -m \n" + " --dump-tpmc= Dump a mermaid graph of the TPMC " + "state table.\n" + " -e\n" + " --exec= Execute the snippet of code directly\n" + " -i\n" + " --include= Add dir to the list of directories to " + "be searched.\n" + " --parse-only Stop after parsing to enable " + "parser-only profiling.\n" + " --report Report statistics.\n" #ifdef DEBUG_STRESS_GC - " --stress-gc Stress the garbage collector.\n" + " --stress-gc Stress the garbage collector.\n" #endif #ifdef UNIT_TESTS - " --test Run unit tests.\n" + " --test Run unit tests.\n" #endif ); exit(status); @@ -163,7 +181,7 @@ static void usage(char *prog, int status) { /** * Process command-line arguments. - * + * * @param argc the argument count * @param argv the argument values * @return the index of the first non-option argument @@ -174,31 +192,32 @@ static int processArgs(int argc, char *argv[]) { while (1) { static struct option long_options[] = { #ifdef UNIT_TESTS - { "test", no_argument, &test_flag, 1 }, + {"test", no_argument, &test_flag, 1}, #endif - { "report", no_argument, &report_flag, 1 }, + {"report", no_argument, &report_flag, 1}, #ifdef DEBUG_STRESS_GC - { "stress-gc", no_argument, &forceGcFlag, 1 }, + {"stress-gc", no_argument, &forceGcFlag, 1}, #endif - { "parse-only", no_argument, &parse_only_flag, 1 }, - { "dump-anf", no_argument, &anf_flag, 1 }, - { "dump-ast", no_argument, &ast_flag, 1 }, - { "dump-bytecode", no_argument, &dump_bytecode_flag, 1 }, - { "exec", required_argument, 0, 'e' }, - { "help", no_argument, 0, 'h' }, - { "dump-inline", no_argument, &inline_flag, 1 }, - { "assertions-accumulate", no_argument, &assertions_accumulate, 1 }, - { "dump-tpmc", required_argument, 0, 'm' }, - { "dump-lambda", optional_argument, 0, 'l' }, - { "dump-alpha", optional_argument, 0, 'a' }, - { "include", required_argument, 0, 'i' }, - { "binary-out", required_argument, 0, 'o' }, - { "binary-in", required_argument, 0, 'b' }, - { 0, 0, 0, 0 } - }; + {"parse-only", no_argument, &parse_only_flag, 1}, + {"dump-anf", no_argument, &anf_flag, 1}, + {"dump-ast", no_argument, &ast_flag, 1}, + {"dump-bytecode", no_argument, &dump_bytecode_flag, 1}, + {"exec", required_argument, 0, 'e'}, + {"help", no_argument, 0, 'h'}, + {"dump-inline", no_argument, &inline_flag, 1}, + {"assertions-accumulate", no_argument, &assertions_accumulate, 1}, + {"dump-tpmc", required_argument, 0, 'm'}, + {"dump-lambda", optional_argument, 0, 'l'}, + {"dump-desugared", optional_argument, 0, 'd'}, + {"dump-alpha", optional_argument, 0, 'a'}, + {"include", required_argument, 0, 'i'}, + {"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:", long_options, &option_index); + c = getopt_long(argc, argv, "l::hm:e:i:o:b:d::a::", long_options, + &option_index); if (c == -1) break; @@ -223,6 +242,14 @@ static int processArgs(int argc, char *argv[]) { } } + if (c == 'd') { + if (optarg) { + desugar_conversion_function = optarg; + } else { + desugar_flag = 1; + } + } + if (c == 'o') { binary_output_file = optarg; } @@ -236,7 +263,7 @@ static int processArgs(int argc, char *argv[]) { } if (c == 'i') { - pushAstStringArray(include_paths, strdup(optarg)); + pushStringArray(include_paths, strdup(optarg)); } if (c == '?' || c == 'h') { @@ -255,7 +282,7 @@ static int processArgs(int argc, char *argv[]) { if (optind >= argc && !binary_input_file && !snippet #ifdef UNIT_TESTS - && !test_flag + && !test_flag #endif ) { eprintf("missing argument\n"); @@ -267,7 +294,7 @@ static int processArgs(int argc, char *argv[]) { /** * Parse a file from the command line into an AST program. - * + * * @param file the fileName * @return the AST program */ @@ -278,7 +305,7 @@ static AstProg *parseFile(char *file) { exit(1); } if (ast_flag) { - AstUTF8 *dest = newAstUTF8(); + SCharArray *dest = newSCharArray(); PROTECT(dest); ppAstProg(dest, prog); printf("%s\n", dest->entries); @@ -289,7 +316,7 @@ static AstProg *parseFile(char *file) { /** * Parse a string into an AST program. - * + * * @param string the string to parse * @return the AST program */ @@ -300,7 +327,7 @@ static AstProg *parseString(char *string) { exit(1); } if (ast_flag) { - AstUTF8 *dest = newAstUTF8(); + SCharArray *dest = newSCharArray(); PROTECT(dest); ppAstProg(dest, prog); printf("%s\n", dest->entries); @@ -311,7 +338,7 @@ static AstProg *parseString(char *string) { /** * Convert an AST program into a lambda expression. - * + * * @param prog the AST program * @return the lambda expression */ @@ -335,7 +362,7 @@ static LamExp *inlineExp(LamExp *exp) __attribute__((unused)); /** * Inline type constructors in a lambda expression. - * + * * @param exp the lambda expression * @return the inlined lambda expression */ @@ -352,7 +379,7 @@ static LamExp *inlineExp(LamExp *exp) { /** * Type check a lambda expression. - * + * * @param exp the lambda expression * @param builtIns the built-in functions */ @@ -372,7 +399,7 @@ static void typeCheck(LamExp *exp, BuiltIns *builtIns) { /** * Annotate an ANF expression, adding location information for symbols - * + * * @param anfExp the ANF expression * @param builtIns the built-in functions */ @@ -386,7 +413,7 @@ static void annotate(AnfExp *anfExp, BuiltIns *builtIns) { /** * Generate byte codes from an ANF expression. - * + * * @param anfExp the ANF expression * @param L the location array * @return the generated byte codes @@ -401,7 +428,7 @@ static ByteCodeArray generateByteCodes(AnfExp *anfExp, LocationArray *L) { /** * Report statistics on the execution. - * + * * @param prog the program name * @param begin the begin time * @param compiled the compile time @@ -411,11 +438,11 @@ static void report(char *prog, clock_t begin, clock_t compiled, clock_t end) { if (report_flag) { printf("\n"); report_build_mode(prog); - double time_spent = (double) (end - begin) / CLOCKS_PER_SEC; + double time_spent = (double)(end - begin) / CLOCKS_PER_SEC; printf("elapsed time: %.4lf\n", time_spent); - double compile_time = (double) (compiled - begin) / CLOCKS_PER_SEC; + double compile_time = (double)(compiled - begin) / CLOCKS_PER_SEC; printf("compile time: %.4lf\n", compile_time); - double run_time = (double) (end - compiled) / CLOCKS_PER_SEC; + double run_time = (double)(end - compiled) / CLOCKS_PER_SEC; printf("run time: %.4lf\n", run_time); reportMemory(); reportSteps(); @@ -424,7 +451,7 @@ static void report(char *prog, clock_t begin, clock_t compiled, clock_t end) { /** * Main entry point for the program. - * + * * @param argc the argument count * @param argv the argument values * @return the exit status @@ -432,38 +459,39 @@ static void report(char *prog, clock_t begin, clock_t compiled, clock_t end) { int main(int argc, char *argv[]) { clock_t begin = clock(); initAll(); - include_paths = newAstStringArray(); + include_paths = newStringArray(); int save = PROTECT(include_paths); int nextargc = processArgs(argc, argv); - BuiltIns *builtIns = registerBuiltIns(argc, binary_input_file ? nextargc : nextargc + 1, argv); + BuiltIns *builtIns = registerBuiltIns( + argc, binary_input_file ? nextargc : nextargc + 1, argv); PROTECT(builtIns); #ifdef UNIT_TESTS if (test_flag) { - if(run_unit_tests()) { + if (run_unit_tests()) { exit(0); } else { exit(1); } } else #endif - if (binary_input_file) { + if (binary_input_file) { ByteCodeArray byteCodes; initByteCodeArray(&byteCodes, 8); switch (readBinaryInputFile(&byteCodes, binary_input_file)) { - case BYTECODES_BADFILE: - fprintf(stderr, "%s: %s\n", binary_input_file, strerror(errno)); - exit(1); - case BYTECODES_BADHEADER: - fprintf(stderr, "%s: invalid header\n", binary_input_file); - exit(1); - case BYTECODES_BADVERSION: - fprintf(stderr, "%s: invalid version\n", binary_input_file); - exit(1); - case BYTECODES_OK: - break; - default: - cant_happen("unrecognised status from bytecode reader"); + case BYTECODES_BADFILE: + fprintf(stderr, "%s: %s\n", binary_input_file, strerror(errno)); + exit(1); + case BYTECODES_BADHEADER: + fprintf(stderr, "%s: invalid header\n", binary_input_file); + exit(1); + case BYTECODES_BADVERSION: + fprintf(stderr, "%s: invalid version\n", binary_input_file); + exit(1); + case BYTECODES_OK: + break; + default: + cant_happen("unrecognised status from bytecode reader"); } clock_t compiled = clock(); run(byteCodes, NULL, builtIns); @@ -497,6 +525,15 @@ int main(int argc, char *argv[]) { exp = inlineExp(exp); REPLACE_PROTECT(save2, exp); + MinExp *minExp = desugarLamExp(exp); + REPLACE_PROTECT(save2, minExp); + + if (desugar_flag) { + ppMinExp(minExp); + eprintf("\n"); + exit(0); + } + #if 0 // forceGcFlag = true; LamExp *anfLam = anfNormalize2(exp); @@ -505,8 +542,8 @@ int main(int argc, char *argv[]) { eprintf("\n"); exit(0); #endif - exp = alphaConvertLamExp(exp, builtIns); - REPLACE_PROTECT(save2, exp); + minExp = alphaConvertMinExp(minExp, builtIns); + REPLACE_PROTECT(save2, minExp); #ifdef TEST_CPS LamExp *halt = newLamExp_Var(CPI(exp), newSymbol("halt")); PROTECT(halt); @@ -519,12 +556,12 @@ int main(int argc, char *argv[]) { #endif if (alpha_flag) { - ppLamExp(exp); + ppMinExp(minExp); eprintf("\n"); exit(0); } - AnfExp *anfExp = anfNormalize(exp); + AnfExp *anfExp = anfNormalize(minExp); REPLACE_PROTECT(save2, anfExp); if (anf_flag) { @@ -539,7 +576,8 @@ int main(int argc, char *argv[]) { ByteCodeArray byteCodes = generateByteCodes(anfExp, L); if (binary_output_file != NULL) { if (!writeBinaryOutputFile(&byteCodes, binary_output_file)) { - fprintf(stderr, "%s: %s\n", binary_output_file, strerror(errno)); + fprintf(stderr, "%s: %s\n", binary_output_file, + strerror(errno)); exit(1); } exit(0); diff --git a/src/memory.c b/src/memory.c index 4be85383..0b540f5d 100644 --- a/src/memory.c +++ b/src/memory.c @@ -23,16 +23,16 @@ #include #include -#include "common.h" +#include "anf.h" #include "annotate.h" +#include "arithmetic.h" +#include "builtin_io.h" +#include "cekf.h" +#include "common.h" #include "memory.h" +#include "opaque.h" #include "step.h" -#include "anf.h" -#include "cekf.h" #include "symbol.h" -#include "arithmetic.h" -#include "opaque.h" -#include "builtin_io.h" #include "wrapper_synthesis.h" static int bytesAllocated = 0; @@ -49,10 +49,10 @@ int forceGcFlag = 0; #endif /** - * The ProtectionStack structure is used to ensure objects that are in the process - * of being constructed are not collected by the garbage collector. It is the structure - * that is operated on by the PROTECT, REPLACE_PROTECT and UNPROTECT macros, which - * push and pop objects to be protected from collection. + * The ProtectionStack structure is used to ensure objects that are in the + * process of being constructed are not collected by the garbage collector. It + * is the structure that is operated on by the PROTECT, REPLACE_PROTECT and + * UNPROTECT macros, which push and pop objects to be protected from collection. */ typedef struct ProtectionStack { Header header; @@ -73,62 +73,60 @@ void reportMemory() { static Header *allocated = NULL; -void validateLastAlloc() { - lastAlloc = NULL; -} +void validateLastAlloc() { lastAlloc = NULL; } /** * Returns a string representation of the given ObjType. * Used for debugging output. - * + * * It defers to the generated typenameXXXObj functions * for the various groups of generated object types, but * handles the primitive object types itself. - * + * * @param type the ObjType to be named * @return string representation of the ObjType */ -__attribute__((unused)) -static const char *typeName(ObjType type) { +__attribute__((unused)) static const char *typeName(ObjType type) { switch (type) { - case OBJTYPE_OPAQUE: - return "opaque"; - case OBJTYPE_HASHTABLE: - return "hashtable"; - case OBJTYPE_PROTECTION: - return "protection"; - case OBJTYPE_BIGINT: - return "bigint"; - case OBJTYPE_AGNOSTICFILEID: - return "file_id"; - case OBJTYPE_MAYBEBIGINT: - return "maybebigint"; + case OBJTYPE_OPAQUE: + return "opaque"; + case OBJTYPE_HASHTABLE: + return "hashtable"; + case OBJTYPE_PROTECTION: + return "protection"; + case OBJTYPE_BIGINT: + return "bigint"; + case OBJTYPE_MAYBEBIGINT: + return "maybebigint"; ANF_OBJTYPE_CASES() - return typenameAnfObj(type); + return typenameAnfObj(type); AST_OBJTYPE_CASES() - return typenameAstObj(type); + return typenameAstObj(type); LAMBDA_OBJTYPE_CASES() - return typenameLambdaObj(type); + return typenameLambdaObj(type); + MINLAM_OBJTYPE_CASES() + return typenameMinlamObj(type); TPMC_OBJTYPE_CASES() - return typenameTpmcObj(type); + return typenameTpmcObj(type); TC_OBJTYPE_CASES() - return typenameTcObj(type); + return typenameTcObj(type); BUILTINS_OBJTYPE_CASES() - return typenameBuiltinsObj(type); + return typenameBuiltinsObj(type); PRATT_OBJTYPE_CASES() - return typenamePrattObj(type); + return typenamePrattObj(type); CEKFS_OBJTYPE_CASES() - return typenameCekfsObj(type); + return typenameCekfsObj(type); ANF_KONT_OBJTYPE_CASES() - return typenameAnf_kontObj(type); + return typenameAnf_kontObj(type); CPS_KONT_OBJTYPE_CASES() - return typenameCps_kontObj(type); - default: { - static char buf[64]; - snprintf(buf, sizeof(buf), "%d", type); - return buf; - } - + return typenameCps_kontObj(type); + UTILS_OBJTYPE_CASES() + return typenameUtilsObj(type); + default: { + static char buf[64]; + snprintf(buf, sizeof(buf), "%d", type); + return buf; + } } } @@ -154,8 +152,15 @@ bool disableGC() { } #define INITIAL_PROTECTION 8 -#define NEW_PROTECT(size) ((ProtectionStack *)allocate(sizeof(ProtectionStack) + size * sizeof(Header *), OBJTYPE_PROTECTION)) -#define FREE_PROTECT(p) ((void)reallocate(p, sizeof(ProtectionStack) + ((ProtectionStack *)p)->capacity * sizeof(Header *), 0)) +#define NEW_PROTECT(size) \ + ((ProtectionStack *)allocate(sizeof(ProtectionStack) + \ + size * sizeof(Header *), \ + OBJTYPE_PROTECTION)) +#define FREE_PROTECT(p) \ + ((void)reallocate(p, \ + sizeof(ProtectionStack) + \ + ((ProtectionStack *)p)->capacity * sizeof(Header *), \ + 0)) void initProtection(void) { #ifdef DEBUG_LOG_GC @@ -169,19 +174,18 @@ void initProtection(void) { /** * invoked by the REPLACE_PROTECT macro */ -void replaceProtect(Index i, Header *obj) { - protected->stack[i] = obj; -} +void replaceProtect(Index i, Header *obj) { protected->stack[i] = obj; } /** * Invoked by the PROTECT macro. * Pushes the given object onto the ProtectionStack * and returns the stack pointer index of the pushed object. - * + * * This function ensures that it will never attempt a memory allocation * (which might trigger a garbage collection) before the object to be protected * is safely on the ProtectionStack. - * It does this by reallocating the stack to a larger size if the stack is at capacity + * It does this by reallocating the stack to a larger size if the stack is at + * capacity * **after** pushing the object onto the stack. */ Index protect(Header *obj) { @@ -196,7 +200,7 @@ Index protect(Header *obj) { protected->stack[protected->sp++] = obj; if (protected->sp == protected->capacity) { #ifdef DEBUG_LOG_GC - eprintf("protect old stack: %p\n", (void *) protected); + eprintf("protect old stack: %p\n", (void *)protected); #endif ProtectionStack *tmp = NEW_PROTECT(protected->capacity * 2); tmp->capacity = protected->capacity * 2; @@ -204,12 +208,12 @@ Index protect(Header *obj) { COPY_ARRAY(Header *, tmp->stack, protected->stack, protected->sp); protected = tmp; #ifdef DEBUG_LOG_GC - eprintf("protect new stack: %p\n", (void *) protected); + eprintf("protect new stack: %p\n", (void *)protected); #endif } #ifdef DEBUG_LOG_GC - eprintf("PROTECT(%s) done -> %d (%d)\n", typeName(obj->type), - protected->sp, protected->capacity); + eprintf("PROTECT(%s) done -> %d (%d)\n", typeName(obj->type), protected->sp, + protected->capacity); #endif return protected->sp - 1; } @@ -235,9 +239,9 @@ void unProtect(Index index) { */ void *reallocate(void *pointer, size_t oldSize, size_t newSize) { #ifdef DEBUG_LOG_GC - eprintf - ("reallocate bytesAllocated %d + newsize %lu - oldsize %lu [%d] pointer %p\n", - bytesAllocated, newSize, oldSize, numAlloc, pointer); + eprintf("reallocate bytesAllocated %d + newsize %lu - oldsize %lu [%d] " + "pointer %p\n", + bytesAllocated, newSize, oldSize, numAlloc, pointer); if (newSize > oldSize) numAlloc++; if (newSize < oldSize) @@ -256,9 +260,9 @@ void *reallocate(void *pointer, size_t oldSize, size_t newSize) { if (newSize > oldSize) { #ifdef DEBUG_STRESS_GC -if (forceGcFlag || bytesAllocated > nextGC) { - collectGarbage(); -} + if (forceGcFlag || bytesAllocated > nextGC) { + collectGarbage(); + } #else if (bytesAllocated > nextGC) { collectGarbage(); @@ -269,7 +273,7 @@ if (forceGcFlag || bytesAllocated > nextGC) { if (newSize == 0) { #ifdef DEBUG_STRESS_GC if (forceGcFlag) { - char *zerop = (char *) pointer; + char *zerop = (char *)pointer; for (size_t i = 0; i < oldSize; i++) { zerop[i] = '\0'; } @@ -299,10 +303,10 @@ if (forceGcFlag || bytesAllocated > nextGC) { */ void *allocate(size_t size, ObjType type) { #ifdef DEBUG_LOG_GC - eprintf("allocate type %s %d %lu [%d]\n", typeName(type), - bytesAllocated, size, numAlloc); + eprintf("allocate type %s %d %lu [%d]\n", typeName(type), bytesAllocated, + size, numAlloc); #endif - Header *newObj = (Header *) reallocate(NULL, (size_t) 0, size); + Header *newObj = (Header *)reallocate(NULL, (size_t)0, size); newObj->type = type; newObj->keep = false; newObj->next = allocated; @@ -312,7 +316,7 @@ void *allocate(size_t size, ObjType type) { } else { lastAlloc = NULL; } - return (void *) newObj; + return (void *)newObj; } /** @@ -324,7 +328,7 @@ static void markProtectionObj(Header *h) { eprintf("markProtectionObj\n"); #endif MARK(h); - ProtectionStack *protected = (ProtectionStack *) h; + ProtectionStack *protected = (ProtectionStack *)h; for (Index i = 0; i < protected->sp; ++i) { markObj(protected->stack[i], i); } @@ -337,7 +341,7 @@ static void markProtectionObj(Header *h) { * Part of the mark phase of the mark-sweep garbage collection, * marks the given object by dispatching to the appropriate * type-specific marking function. - * + * * @param h pointer to the Header of the object to be marked * @param i index on the ProtectionStack, for debugging output */ @@ -346,126 +350,129 @@ void markObj(Header *h, Index i) { // eprintf("markObj [%d]%s %p\n", i, typeName(h->type), h); #endif switch (h->type) { - case OBJTYPE_OPAQUE: - markOpaque((Opaque *) h); - break; - case OBJTYPE_MAYBEBIGINT: - markMaybeBigInt((MaybeBigInt *) h); - break; - case OBJTYPE_BIGINT: - markBigInt((BigInt *) h); - break; - case OBJTYPE_AGNOSTICFILEID: - markAgnosticFileId((AgnosticFileId *)h); - break; - case OBJTYPE_HASHTABLE: - markHashTableObj(h); - break; - case OBJTYPE_PROTECTION: - markProtectionObj(h); - break; + case OBJTYPE_OPAQUE: + markOpaque((Opaque *)h); + break; + case OBJTYPE_MAYBEBIGINT: + markMaybeBigInt((MaybeBigInt *)h); + break; + case OBJTYPE_BIGINT: + markBigInt((BigInt *)h); + break; + case OBJTYPE_HASHTABLE: + markHashTableObj(h); + break; + case OBJTYPE_PROTECTION: + markProtectionObj(h); + break; CEKFS_OBJTYPE_CASES() - markCekfsObj(h); - break; + markCekfsObj(h); + break; PRATT_OBJTYPE_CASES() - markPrattObj(h); - break; + markPrattObj(h); + break; ANF_OBJTYPE_CASES() - markAnfObj(h); - break; + markAnfObj(h); + break; AST_OBJTYPE_CASES() - markAstObj(h); - break; + markAstObj(h); + break; LAMBDA_OBJTYPE_CASES() - markLambdaObj(h); - break; + markLambdaObj(h); + break; + MINLAM_OBJTYPE_CASES() + markMinlamObj(h); + break; TPMC_OBJTYPE_CASES() - markTpmcObj(h); - break; + markTpmcObj(h); + break; TC_OBJTYPE_CASES() - markTcObj(h); - break; + markTcObj(h); + break; BUILTINS_OBJTYPE_CASES() - markBuiltinsObj(h); - break; + markBuiltinsObj(h); + break; ANF_KONT_OBJTYPE_CASES() - markAnf_kontObj(h); - break; + markAnf_kontObj(h); + break; CPS_KONT_OBJTYPE_CASES() - markCps_kontObj(h); - break; - default: - cant_happen("unrecognised ObjType %d in markObj at [%d]", h->type, - i); + markCps_kontObj(h); + break; + UTILS_OBJTYPE_CASES() + markUtilsObj(h); + break; + default: + cant_happen("unrecognised ObjType %d in markObj at [%d]", h->type, i); } } /** * Frees the given ProtectionStack object. */ -static void freeProtectionObj(Header *h) { - FREE_PROTECT(h); -} +static void freeProtectionObj(Header *h) { FREE_PROTECT(h); } /** * Frees the given object by dispatching to the appropriate * type-specific free function. - * + * * @param h pointer to the Header of the object to be freed */ void freeObj(Header *h) { switch (h->type) { - case OBJTYPE_OPAQUE: - freeOpaque((Opaque *) h); - break; - case OBJTYPE_BIGINT: - freeBigInt((BigInt *) h); - break; - case OBJTYPE_MAYBEBIGINT: - freeMaybeBigInt((MaybeBigInt *) h); - break; - case OBJTYPE_AGNOSTICFILEID: - freeAgnosticFileId((AgnosticFileId *) h); - break; - case OBJTYPE_HASHTABLE: - freeHashTableObj(h); - break; - case OBJTYPE_PROTECTION: - freeProtectionObj(h); - break; + case OBJTYPE_OPAQUE: + freeOpaque((Opaque *)h); + break; + case OBJTYPE_BIGINT: + freeBigInt((BigInt *)h); + break; + case OBJTYPE_MAYBEBIGINT: + freeMaybeBigInt((MaybeBigInt *)h); + break; + case OBJTYPE_HASHTABLE: + freeHashTableObj(h); + break; + case OBJTYPE_PROTECTION: + freeProtectionObj(h); + break; CEKFS_OBJTYPE_CASES() - freeCekfsObj(h); - break; + freeCekfsObj(h); + break; PRATT_OBJTYPE_CASES() - freePrattObj(h); - break; + freePrattObj(h); + break; ANF_OBJTYPE_CASES() - freeAnfObj(h); - break; + freeAnfObj(h); + break; AST_OBJTYPE_CASES() - freeAstObj(h); - break; + freeAstObj(h); + break; + MINLAM_OBJTYPE_CASES() + freeMinlamObj(h); + break; LAMBDA_OBJTYPE_CASES() - freeLambdaObj(h); - break; + freeLambdaObj(h); + break; TPMC_OBJTYPE_CASES() - freeTpmcObj(h); - break; + freeTpmcObj(h); + break; TC_OBJTYPE_CASES() - freeTcObj(h); - break; + freeTcObj(h); + break; BUILTINS_OBJTYPE_CASES() - freeBuiltinsObj(h); - break; + freeBuiltinsObj(h); + break; ANF_KONT_OBJTYPE_CASES() - freeAnf_kontObj(h); - break; + freeAnf_kontObj(h); + break; CPS_KONT_OBJTYPE_CASES() - freeCps_kontObj(h); - break; - default: - cant_happen("unrecognised ObjType %d in freeObj at %p", h->type, - (void *) h); + freeCps_kontObj(h); + break; + UTILS_OBJTYPE_CASES() + freeUtilsObj(h); + break; + default: + cant_happen("unrecognised ObjType %d in freeObj at %p", h->type, + (void *)h); } } @@ -475,7 +482,7 @@ void freeObj(Header *h) { */ static void markProtected() { if (protected != NULL) - markProtectionObj((Header *) protected); + markProtectionObj((Header *)protected); } /** @@ -504,13 +511,13 @@ static void mark() { /** * The sweep phase of the mark-sweep garbage collection. * Frees all unmarked objects and clears the marks on the marked objects. - * + * * The Header component structure common to all memory-managed structures * contains a 'keep' field which is used as the mark bit, - * and a 'next' field which is used to link all allocated objects into a single list. - * Any object whose 'keep' field is false is simply snipped from the list and freed. - * Any object whose 'keep' field is true has its 'keep' field cleared for the - * next garbage collection cycle. + * and a 'next' field which is used to link all allocated objects into a single + * list. Any object whose 'keep' field is false is simply snipped from the list + * and freed. Any object whose 'keep' field is true has its 'keep' field cleared + * for the next garbage collection cycle. */ static void sweep() { Header *current = allocated; @@ -521,9 +528,8 @@ static void sweep() { current->keep = false; } else { #ifdef DEBUG_LOG_GC - eprintf("sweep discard %p\n", (void *) current); - eprintf(" type %s\n", - typeName(current->type)); + eprintf("sweep discard %p\n", (void *)current); + eprintf(" type %s\n", typeName(current->type)); #endif *previous = current->next; freeObj(current); @@ -534,7 +540,7 @@ static void sweep() { /** * Performs a garbage collection cycle if garbage collection is enabled. - * + * * The cycle consists of a mark phase and a sweep phase. * After the collection, the threshold for the next collection * is set to double the current bytes allocated. diff --git a/src/memory.h b/src/memory.h index 8313163d..ee266e2c 100644 --- a/src/memory.h +++ b/src/memory.h @@ -1,5 +1,5 @@ #ifndef cekf_memory_h -# define cekf_memory_h +#define cekf_memory_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,22 +18,24 @@ * along with this program. If not, see . */ -# include -# include +#include +#include struct Header; -# include "ast_objtypes.h" -# include "anf_objtypes.h" -# include "lambda_objtypes.h" -# include "tpmc_objtypes.h" -# include "tc_objtypes.h" -# include "cekfs_objtypes.h" -# include "builtins_objtypes.h" -# include "pratt_objtypes.h" -# include "anf_kont_objtypes.h" -# include "cps_kont_objtypes.h" -# include "types.h" +#include "anf_kont_objtypes.h" +#include "anf_objtypes.h" +#include "ast_objtypes.h" +#include "builtins_objtypes.h" +#include "cekfs_objtypes.h" +#include "cps_kont_objtypes.h" +#include "lambda_objtypes.h" +#include "minlam_objtypes.h" +#include "pratt_objtypes.h" +#include "tc_objtypes.h" +#include "tpmc_objtypes.h" +#include "types.h" +#include "utils_objtypes.h" // Definition of all object types for garbage collection typedef enum { @@ -50,14 +52,12 @@ typedef enum { // arithmetic types OBJTYPE_BIGINT, OBJTYPE_MAYBEBIGINT, - - // file id type used to track linked nameSpaces - OBJTYPE_AGNOSTICFILEID, // various generated object types ANF_OBJTYPES(), AST_OBJTYPES(), LAMBDA_OBJTYPES(), + MINLAM_OBJTYPES(), TPMC_OBJTYPES(), TC_OBJTYPES(), BUILTINS_OBJTYPES(), @@ -65,6 +65,7 @@ typedef enum { PRATT_OBJTYPES(), ANF_KONT_OBJTYPES(), CPS_KONT_OBJTYPES(), + UTILS_OBJTYPES(), } ObjType; typedef struct Header { @@ -93,25 +94,35 @@ void validateLastAlloc(void); void reportMemory(void); void collectGarbage(); -# define EXIT_OOM 2 +#define EXIT_OOM 2 -#define NEW_VECTOR(size, type, element_type, tag) ((type *)allocate(sizeof(type) + (size) * sizeof(element_type), (tag))) -#define FREE_VECTOR(vector, type, element_type, count) ((void)reallocate(vector, sizeof(type) + (count) * sizeof(element_type), 0)) +#define NEW_VECTOR(size, type, element_type, tag) \ + ((type *)allocate(sizeof(type) + (size) * sizeof(element_type), (tag))) +#define FREE_VECTOR(vector, type, element_type, count) \ + ((void)reallocate(vector, sizeof(type) + (count) * sizeof(element_type), 0)) -# define NEW_VEC(size) ((Vec *)allocate(sizeof(Vec) + size * sizeof(Value), OBJTYPE_VEC)) -# define FREE_VEC(vec) ((void)reallocate(vec, sizeof(vec) + vec->size * sizeof(Value), 0)) +#define NEW_VEC(size) \ + ((Vec *)allocate(sizeof(Vec) + size * sizeof(Value), OBJTYPE_VEC)) +#define FREE_VEC(vec) \ + ((void)reallocate(vec, sizeof(vec) + vec->size * sizeof(Value), 0)) // Allocation for directly managed objects -# define NEW(thing, type) ((thing *)allocate(sizeof(thing), type)) -# define FREE(thing, type) ((void)reallocate(thing, sizeof(type), 0)) +#define NEW(thing, type) ((thing *)allocate(sizeof(thing), type)) +#define FREE(thing, type) ((void)reallocate(thing, sizeof(type), 0)) // Allocation for indirectly managed objects -# define ALLOCATE(type) ((type *)reallocate(NULL, 0, sizeof(type))) - -# define NEW_ARRAY(type, count) ((type *)reallocate(NULL, 0, sizeof(type) * (count))) -# define FREE_ARRAY(type, array, count) ((void)reallocate(array, sizeof(type) * (count), 0)) -# define GROW_ARRAY(type, array, oldcount, newcount) ((type *)reallocate(array, sizeof(type) * (oldcount), sizeof(type) * (newcount))) -# define MOVE_ARRAY(type, dest, src, amount) (memmove((dest), (src), sizeof(type) * (amount))) -# define COPY_ARRAY(type, dest, src, amount) (memcpy((dest), (src), sizeof(type) * (amount))) +#define ALLOCATE(type) ((type *)reallocate(NULL, 0, sizeof(type))) + +#define NEW_ARRAY(type, count) \ + ((type *)reallocate(NULL, 0, sizeof(type) * (count))) +#define FREE_ARRAY(type, array, count) \ + ((void)reallocate(array, sizeof(type) * (count), 0)) +#define GROW_ARRAY(type, array, oldcount, newcount) \ + ((type *)reallocate(array, sizeof(type) * (oldcount), \ + sizeof(type) * (newcount))) +#define MOVE_ARRAY(type, dest, src, amount) \ + (memmove((dest), (src), sizeof(type) * (amount))) +#define COPY_ARRAY(type, dest, src, amount) \ + (memcpy((dest), (src), sizeof(type) * (amount))) /** * VERY IMPORTANT macros: @@ -123,13 +134,13 @@ void collectGarbage(); * stack pointer index of the pushed object, which can be used * to unprotect the object later. */ -# define PROTECT(x) protect((Header *)(x)) +#define PROTECT(x) protect((Header *)(x)) /** * UNPROTECT restores the ProtectionStack to its argument index, * effectively removing all objects at and above that index from the * ProtectionStack. */ -# define UNPROTECT(i) unProtect(i) +#define UNPROTECT(i) unProtect(i) /** * REPLACE_PROTECT replaces the object at the * given index on the ProtectionStack with the given replacement. @@ -137,16 +148,16 @@ void collectGarbage(); * the object that replaces it, since mark and sweep will automatically * protect the contained object. */ -# define REPLACE_PROTECT(i, x) replaceProtect(i, (Header *)(x)) +#define REPLACE_PROTECT(i, x) replaceProtect(i, (Header *)(x)) /** * STARTPROTECT just returns the current stack pointer, a later * UNPROTECT will restore the stack to this point, having no effect * if nothing has been pushed onto the stack since. */ -# define STARTPROTECT() protect(NULL); +#define STARTPROTECT() protect(NULL); -# define MARK(obj) (((Header *)(obj))->keep = true) -# define MARKED(obj) (((Header *)(obj))->keep == true) +#define MARK(obj) (((Header *)(obj))->keep = true) +#define MARKED(obj) (((Header *)(obj))->keep == true) #define safeMalloc(size) reallocate(NULL, 0, size) #endif diff --git a/src/minlam.yaml b/src/minlam.yaml new file mode 100644 index 00000000..45f48bf6 --- /dev/null +++ b/src/minlam.yaml @@ -0,0 +1,249 @@ +# +# 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 . +# + +config: + name: minlam + description: Minimal AST after desugaring + parserInfo: true + includes: + - utils.h + limited_includes: + - bigint.h + - tc.h + - tc_debug.h + - minlam_functions.h + +structs: + MinLam: + meta: + brief: A lambda expression + data: + args: SymbolList + exp: MinExp + + MinExprList: + meta: + brief: A list of expressions + data: + exp: MinExp + next: MinExprList + + MinPrimApp: + meta: + brief: A primitive operation application + data: + type: MinPrimOp + exp1: MinExp + exp2: MinExp + + MinApply: + meta: + brief: A function application. + data: + function: MinExp + args: MinExprList + + MinLookUp: + meta: + brief: A lookUp in a nameSpace + description: >- + Allows the evaluation of an expression + in a different nameSpace. Typically the + expression is just a variable but it can + be any expression. + data: + nsId: int + exp: MinExp + + MinIff: + meta: + brief: An if-then-else expression + data: + condition: MinExp + consequent: MinExp + alternative: MinExp + + MinCond: + meta: + brief: A conditional expression with multiple cases. + description: >- + Used internally by the generated TPMC code, the cases can + be either integers (matcing type constructor tags) or characters + (matching literal characters). The type of the value must match + the type of the cases. + data: + value: MinExp + cases: MinCondCases + + MinIntCondCases: + meta: + brief: Integer conditional cases + data: + constant: MaybeBigInt + body: MinExp + next: MinIntCondCases + + MinCharCondCases: + meta: + brief: Character conditional cases + data: + constant: character + body: MinExp + next: MinCharCondCases + + MinMatch: + meta: + brief: An integer matching expression + description: >- + Matches an integer index against multiple lists of cases. Each list + of cases is associated with a body expression to be executed on match. + Again this is generated by the TPMC. + data: + index: MinExp + cases: MinMatchList + + MinMatchList: + meta: + brief: A list of pattern matching cases + data: + matches: MinIntList + body: MinExp + next: MinMatchList + + MinIntList: + meta: + brief: A list of integers + data: + item: int + next: MinIntList + + MinLetRec: + meta: + brief: A letrec expression + data: + bindings: MinBindings + body: MinExp + + MinBindings: + meta: + brief: List of bindings in a letrec expression + data: + var: HashSymbol + val: MinExp + next: MinBindings + + MinAmb: + meta: + brief: An amb expression + data: + left: MinExp + right: MinExp + + MinAlphaEnv: + meta: + brief: An environment for alpha conversion + parserInfo: false + data: + alphaTable: SymbolMap + next: MinAlphaEnv + nameSpaces: MinAlphaEnvArray=NULL + +enums: + MinPrimOp: + meta: + brief: Primitive operations + data: + - ADD + - SUB + - MUL + - DIV + - MOD + - POW + - EQ + - NE + - GT + - LT + - GE + - LE + - CMP + - VEC + +unions: + MinExp: + meta: + brief: An expression + data: + amb: MinAmb + apply: MinApply + args: MinExprList # so that ANF normalize can be uniformly typed + back: void_ptr + bigInteger: MaybeBigInt + bindings: MinBindings # so that ANF normalize can be uniformly typed + callCC: MinExp + character: character + cond: MinCond + env: void_ptr + error: void_ptr + iff: MinIff + lam: MinLam + letRec: MinLetRec + lookUp: MinLookUp + makeVec: MinExprList + match: MinMatch + nameSpaces: MinNameSpaceArray + prim: MinPrimApp + sequence: MinExprList + stdint: int + var: HashSymbol + + MinCondCases: + meta: + brief: Cases for a MinCond + data: + integers: MinIntCondCases + characters: MinCharCondCases + +hashes: + MinExpTable: + meta: + brief: Map from symbols to lambda expressions + data: + entries: MinExp + +arrays: + MinNameSpaceArray: + meta: + brief: A list of nameSpaces + description: >- + This array holds the bodies of all nameSpaces. + `ns_id` is an index into this array. + data: + entries: MinExp + + MinAlphaEnvArray: + meta: + brief: An array of alpha conversion environments per-namespace. + description: >- + Used to alpha-convert lookUp expressions. + data: + entries: MinAlphaEnv + +primitives: !include primitives.yaml + +external: +- !include utils.yaml \ No newline at end of file diff --git a/src/minlam_functions.h b/src/minlam_functions.h new file mode 100644 index 00000000..39829901 --- /dev/null +++ b/src/minlam_functions.h @@ -0,0 +1,25 @@ +#ifndef cekf_minlam_functions_h +#define cekf_minlam_functions_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 . + */ + +struct MinExp; + +#include "lambda_functions.h" + +#endif diff --git a/src/minlam_helper.h b/src/minlam_helper.h new file mode 100644 index 00000000..b967e354 --- /dev/null +++ b/src/minlam_helper.h @@ -0,0 +1,23 @@ +#ifndef cekf_minlam_helper_h +#define cekf_minlam_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 "minlam.h" + +#endif diff --git a/src/minlam_pp.c b/src/minlam_pp.c new file mode 100644 index 00000000..5c65ff34 --- /dev/null +++ b/src/minlam_pp.c @@ -0,0 +1,440 @@ +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2023 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 . + * + * bespoke pretty-printer for minlam.yaml structs + * + */ + +#include "minlam_pp.h" +#include +#include +void ppMinTag(MinExp *tag); + +void ppMinExpD(MinExp *exp, int depth) { + while (depth > 0) { + depth--; + eprintf(" "); + } + ppMinExp(exp); +} + +void ppMinLam(MinLam *lam) { + if (lam == NULL) { + eprintf(""); + return; + } + eprintf("(λ "); + ppMinVarList(lam->args); + eprintf(" "); + ppMinExp(lam->exp); + eprintf(")"); +} + +void ppMinAmb(MinAmb *amb) { + if (amb == NULL) { + eprintf(""); + return; + } + eprintf("(amb "); + ppMinExp(amb->left); + eprintf(" "); + ppMinExp(amb->right); + eprintf(")"); +} + +static void _ppMinVarList(SymbolList *varList) { + if (varList == NULL) + return; + ppHashSymbol(varList->symbol); + if (varList->next != NULL) { + eprintf(" "); + _ppMinVarList(varList->next); + } +} + +void ppMinVarList(SymbolList *varList) { + eprintf("("); + _ppMinVarList(varList); + eprintf(")"); +} + +void ppMinExp(MinExp *exp) { + // sleep(1); + if (exp == NULL) { + eprintf(""); + return; + } + switch (exp->type) { + case MINEXP_TYPE_LAM: + ppMinLam(getMinExp_Lam(exp)); + break; + case MINEXP_TYPE_VAR: + ppHashSymbol(getMinExp_Var(exp)); + break; + case MINEXP_TYPE_BIGINTEGER: + fprintMaybeBigInt(errout, getMinExp_BigInteger(exp)); + break; + case MINEXP_TYPE_STDINT: + eprintf("%d", getMinExp_Stdint(exp)); + break; + case MINEXP_TYPE_PRIM: + ppMinPrimApp(getMinExp_Prim(exp)); + break; + case MINEXP_TYPE_SEQUENCE: + ppMinSequence(getMinExp_Sequence(exp)); + break; + case MINEXP_TYPE_MAKEVEC: + ppMinMakeVec(getMinExp_MakeVec(exp)); + break; + case MINEXP_TYPE_APPLY: + ppMinApply(getMinExp_Apply(exp)); + break; + case MINEXP_TYPE_IFF: + ppMinIff(getMinExp_Iff(exp)); + break; + case MINEXP_TYPE_CALLCC: + ppMinCallCC(getMinExp_CallCC(exp)); // MinExp + break; + case MINEXP_TYPE_LETREC: + ppMinLetRec(getMinExp_LetRec(exp)); + break; + case MINEXP_TYPE_MATCH: + ppMinMatch(getMinExp_Match(exp)); + break; + case MINEXP_TYPE_CHARACTER: + if (getMinExp_Character(exp) == L'\n') + eprintf("\"\\n\""); + else if (getMinExp_Character(exp) == L'\t') + eprintf("\"\\t\""); + else if (getMinExp_Character(exp) == L'\"') + eprintf("\"\\\"\""); + else if (getMinExp_Character(exp) == L'\\') + eprintf("\"\\\\\""); + else + eprintf("\"%lc\"", getMinExp_Character(exp)); + break; + case MINEXP_TYPE_BACK: + eprintf("(back)"); + break; + case MINEXP_TYPE_ERROR: + eprintf("(error)"); + break; + case MINEXP_TYPE_COND: + ppMinCond(getMinExp_Cond(exp)); + break; + case MINEXP_TYPE_AMB: + ppMinAmb(getMinExp_Amb(exp)); + break; + case MINEXP_TYPE_NAMESPACES: + ppMinNameSpaces(getMinExp_NameSpaces(exp)); + break; + case MINEXP_TYPE_ENV: + eprintf("env"); + break; + case MINEXP_TYPE_LOOKUP: + ppMinLookUp(getMinExp_LookUp(exp)); + break; + default: + eprintf("", minExpTypeName(exp->type)); + } +} + +void ppMinLookUp(MinLookUp *lookUp) { + eprintf("(lookUp %d ", lookUp->nsId); + ppMinExp(lookUp->exp); + eprintf(")"); +} + +void ppMinNameSpaces(MinNameSpaceArray *arr) { + eprintf("(nameSpaces"); + for (Index i = 0; i < arr->size; ++i) { + eprintf(" ["); + ppMinExp(arr->entries[i]); + eprintf("]"); + } + eprintf(")"); +} + +void ppMinPrimApp(MinPrimApp *primApp) { + if (primApp == NULL) { + eprintf(""); + return; + } + eprintf("("); + ppMinPrimOp(primApp->type); + eprintf(" "); + ppMinExp(primApp->exp1); + eprintf(" "); + ppMinExp(primApp->exp2); + eprintf(")"); +} + +void ppMinPrimOp(MinPrimOp type) { + switch (type) { + case MINPRIMOP_TYPE_ADD: + eprintf("+"); + break; + case MINPRIMOP_TYPE_SUB: + eprintf("-"); + break; + case MINPRIMOP_TYPE_MUL: + eprintf("*"); + break; + case MINPRIMOP_TYPE_DIV: + eprintf("/"); + break; + case MINPRIMOP_TYPE_EQ: + eprintf("=="); + break; + case MINPRIMOP_TYPE_NE: + eprintf("!="); + break; + case MINPRIMOP_TYPE_GT: + eprintf(">"); + break; + case MINPRIMOP_TYPE_LT: + eprintf("<"); + break; + case MINPRIMOP_TYPE_GE: + eprintf(">="); + break; + case MINPRIMOP_TYPE_LE: + eprintf("<="); + break; + case MINPRIMOP_TYPE_VEC: + eprintf("vec"); + break; + case MINPRIMOP_TYPE_MOD: + eprintf("%%"); + break; + case MINPRIMOP_TYPE_POW: + eprintf("**"); + break; + case MINPRIMOP_TYPE_CMP: + eprintf("<=>"); + break; + default: + eprintf("", minPrimOpName(type)); + } +} + +static void _ppMinSequence(MinExprList *sequence) { + if (sequence == NULL) + return; + ppMinExp(sequence->exp); + if (sequence->next != NULL) { + eprintf(" "); + _ppMinSequence(sequence->next); + } +} + +static void _ppMinArgs(MinExprList *list) { + if (list == NULL) + return; + eprintf(" "); + ppMinExp(list->exp); + _ppMinArgs(list->next); +} + +void ppMinMakeTuple(MinExprList *args) { + eprintf("(make-tuple"); + _ppMinArgs(args); + eprintf(")"); +} + +void ppMinSequence(MinExprList *sequence) { + eprintf("(begin "); + _ppMinSequence(sequence); + eprintf(")"); +} + +void ppMinMakeVec(MinExprList *makeVec) { + eprintf("(make-vec"); + _ppMinArgs(makeVec); + eprintf(")"); +} + +void ppMinApply(MinApply *apply) { + if (apply == NULL) { + eprintf(""); + return; + } + eprintf("("); + ppMinExp(apply->function); + _ppMinArgs(apply->args); + eprintf(")"); +} + +void ppMinIff(MinIff *iff) { + if (iff == NULL) { + eprintf(""); + return; + } + eprintf("(if "); + ppMinExp(iff->condition); + eprintf(" "); + ppMinExp(iff->consequent); + eprintf(" "); + ppMinExp(iff->alternative); + eprintf(")"); +} + +static void _ppMinIntCondCases(MinIntCondCases *cases) { + eprintf("("); + fprintMaybeBigInt(errout, cases->constant); + eprintf(" "); + ppMinExp(cases->body); + eprintf(")"); + if (cases->next != NULL) { + eprintf(" "); + _ppMinIntCondCases(cases->next); + } +} + +static void _ppMinCharCondCases(MinCharCondCases *cases) { + eprintf("(\"%c\" ", cases->constant); + ppMinExp(cases->body); + eprintf(")"); + if (cases->next != NULL) { + eprintf(" "); + _ppMinCharCondCases(cases->next); + } +} + +static void _ppMinCondCases(MinCondCases *cases) { + switch (cases->type) { + case MINCONDCASES_TYPE_INTEGERS: + _ppMinIntCondCases(getMinCondCases_Integers(cases)); + break; + case MINCONDCASES_TYPE_CHARACTERS: + _ppMinCharCondCases(getMinCondCases_Characters(cases)); + break; + default: + eprintf("", + minCondCasesTypeName(cases->type)); + } +} + +void ppMinCond(MinCond *cond) { + if (cond == NULL) { + eprintf(""); + return; + } + eprintf("(cond "); + ppMinExp(cond->value); + if (cond->cases != NULL) { + eprintf(" "); + _ppMinCondCases(cond->cases); + } + eprintf(")"); +} + +void ppMinCallCC(MinExp *exp) { + if (exp == NULL) { + eprintf(""); + return; + } + eprintf("(call/cc "); + ppMinExp(exp); + eprintf(")"); +} + +void ppMinLetRec(MinLetRec *letRec) { + if (letRec == NULL) { + eprintf(""); + return; + } + eprintf("(letrec "); + ppMinBindings(letRec->bindings); + if (letRec->body != NULL) { + eprintf(" "); + ppMinExp(letRec->body); + } + eprintf(")"); +} + +static void _ppMinMatchList(MinMatchList *cases) { + if (cases == NULL) + return; + eprintf("("); + ppMinIntList(cases->matches); + if (cases->body) { + eprintf(" "); + ppMinExp(cases->body); + } + eprintf(")"); + if (cases->next) { + eprintf(" "); + _ppMinMatchList(cases->next); + } +} + +void ppMinMatch(MinMatch *match) { + if (match == NULL) { + eprintf(""); + return; + } + eprintf("(match "); + ppMinExp(match->index); + if (match->cases != NULL) { + eprintf(" "); + _ppMinMatchList(match->cases); + } + eprintf(")"); +} + +static void _ppMinBindings(MinBindings *bindings) { + if (bindings == NULL) + return; + eprintf("("); + ppHashSymbol(bindings->var); + eprintf(" "); + ppMinExp(bindings->val); + eprintf(")"); + if (bindings->next) { + eprintf(" "); + _ppMinBindings(bindings->next); + } +} + +void ppMinBindings(MinBindings *bindings) { + eprintf("("); + _ppMinBindings(bindings); + eprintf(")"); +} + +static void _ppMinIntList(MinIntList *list) { + if (list == NULL) + return; + eprintf("%d", list->item); + if (list->next != NULL) { + eprintf(" "); + _ppMinIntList(list->next); + } +} + +void ppMinIntList(MinIntList *list) { + eprintf("("); + _ppMinIntList(list); + eprintf(")"); +} + +void ppMinTag(MinExp *tag) { + eprintf("(tag "); + ppMinExp(tag); + eprintf(")"); +} \ No newline at end of file diff --git a/src/minlam_pp.h b/src/minlam_pp.h new file mode 100644 index 00000000..dc84b738 --- /dev/null +++ b/src/minlam_pp.h @@ -0,0 +1,47 @@ +#ifndef cekf_minlam_pp_h +#define cekf_minlam_pp_h +/* + * CEKF - VM supporting amb + * Copyright (C) 2022-2023 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 . + * + * bespoke pretty-printer for minlam.yaml structs + * + */ + +#include "minlam.h" + +void ppMinExpD(MinExp *exp, int depth); +void ppMinLam(MinLam *lam); +void ppMinVarList(SymbolList *varList); +void ppMinExp(MinExp *exp); +void ppMinPrimApp(MinPrimApp *primApp); +void ppMinPrimOp(MinPrimOp type); +void ppMinSequence(MinExprList *sequence); +void ppMinMakeVec(MinExprList *args); +void ppMinApply(MinApply *apply); +void ppMinIff(MinIff *iff); +void ppMinCond(MinCond *cond); +void ppMinCallCC(MinExp *exp); +void ppMinLetRec(MinLetRec *letRec); +void ppMinMatch(MinMatch *match); +void ppMinBindings(MinBindings *bindings); +void ppMinIntList(MinIntList *list); +void ppMinMakeTuple(MinExprList *args); +void ppMinNameSpaces(MinNameSpaceArray *arr); +void ppMinLookUp(MinLookUp *lookUp); +void ppHashSymbol(HashSymbol *); + +#endif diff --git a/src/pratt.yaml b/src/pratt.yaml index 0ac4efc8..bd39218f 100644 --- a/src/pratt.yaml +++ b/src/pratt.yaml @@ -20,11 +20,13 @@ config: name: pratt description: Pratt Parser support parserInfo: false + includes: + - utils.h limited_includes: - - file_id.h - ast_helper.h - ast_debug.h - pratt_functions.h + - utils_debug.h structs: # Scanner token parsing @@ -50,7 +52,7 @@ structs: A buffer of wide characters that is both used during parsing and returned by the token parser (like yytext). data: - data: PrattWVec + data: WCharVec start: wstring=NULL offset: int=0 @@ -145,21 +147,6 @@ structs: startsWithHole: bool endsWithHole: bool -vectors: - PrattWVec: - meta: - brief: A fixed-length wchar_t string. - description: >- - data: - entries: character - - PrattCVec: - meta: - brief: A fixed-length char string. - description: >- - data: - entries: schar - enums: PrattAssoc: meta: @@ -222,6 +209,7 @@ inline: isBareSymbol: bool=false export: bool=false pattern: PrattMixfixPattern=NULL + isLazy: bool=false importNsRef: int=-1 importNsSymbol: HashSymbol=NULL @@ -234,7 +222,7 @@ unions: character, or atom. This is used to represent the value of the token in the parse tree. data: - string: PrattUnicode + string: WCharArray number: MaybeBigInt character: character atom: HashSymbol @@ -269,7 +257,7 @@ arrays: An array of Unicode strings that is used to hold multiple keywords for the PrattMixfixPattern structure. data: - entries: PrattUnicode + entries: WCharArray PrattParsers: meta: @@ -282,15 +270,6 @@ arrays: data: entries: PrattParser - PrattUnicode: - meta: - brief: An array of UTF-32 encoded Unicode characters. - description: >- - A UTF-32 encoded array that is used to hold - Unicode strings after parsing. - data: - entries: character - PrattNsOpsArray: meta: brief: Array of exported operator sets indexed by nameSpace reference. @@ -304,9 +283,5 @@ arrays: primitives: !include primitives.yaml external: - AstExpression: - data: - cname: "struct AstExpression *" - printFn: printAstExpression - markFn: markAstExpression - valued: true +- !include ast.yaml +- !include utils.yaml \ No newline at end of file diff --git a/src/pratt_parser.c b/src/pratt_parser.c index 067ba109..494fc816 100644 --- a/src/pratt_parser.c +++ b/src/pratt_parser.c @@ -28,7 +28,6 @@ #include "ast.h" #include "bigint.h" -#include "file_id.h" #include "memory.h" #include "pratt.h" #include "pratt_debug.h" @@ -39,6 +38,7 @@ #include "print_generator.h" #include "symbols.h" #include "unicode.h" +#include "utils.h" #include "wrapper_synthesis.h" #ifdef DEBUG_PRATT_PARSER @@ -47,6 +47,8 @@ #include "debugging_off.h" #endif +typedef enum { DEFUN_FUNCTION, DEFUN_PRINTER, DEFUN_COMPARATOR } DefunType; + // minimal multiplier for converting declared precedence levels to // internal values, to guarantee that adding or subtracting 1 from // an internal precedence will not overlap with an adjacent internal @@ -65,7 +67,7 @@ // right associative infix operators parse the rhs with prec - 1 // pareslets for grouping know their own matching close brace -AstStringArray *include_paths = NULL; +StringArray *include_paths = NULL; static AstAltArgs *altArgs(PrattParser *); static AstAltFunction *altFunction(PrattParser *); @@ -85,8 +87,8 @@ static AstCompositeFunction *functions(PrattParser *); static AstDefinition *alias(PrattParser *); static AstDefinition *assignment(PrattParser *); static AstDefinition *definition(PrattParser *); -static AstDefinition *defMacro(PrattParser *); -static AstDefinition *defun(PrattParser *, bool, bool); +static AstDefinition *defLazy(PrattParser *); +static AstDefinition *defun(PrattParser *, bool, DefunType); static AstDefinition *importOp(PrattParser *); static AstDefinition *exportOp(PrattParser *); static AstDefinition *link(PrattParser *); @@ -123,8 +125,6 @@ static AstExpression *list(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *lookUp(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); -static AstExpression *macro(PrattRecord *, PrattParser *, AstExpression *, - PrattToken *); static AstExpression *makeAtom(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *makeChar(PrattRecord *, PrattParser *, AstExpression *, @@ -164,7 +164,7 @@ static AstExpressions *statements(PrattParser *, HashSymbol *); static AstFileIdArray *fileIdStack = NULL; static AstFunCall *switchFC(PrattParser *parser); static AstLookUpOrSymbol *scopedSymbol(PrattParser *); -static AstNameSpace *parseLink(PrattParser *, unsigned char *, HashSymbol *); +static AstNameSpace *parseLink(PrattParser *, SCharVec *, HashSymbol *); static AstNest *nestBody(PrattParser *, HashSymbol *); static AstNest *childNest(PrattParser *, HashSymbol *); static AstNest *nest(PrattParser *); @@ -182,8 +182,8 @@ static HashSymbol *symbol(PrattParser *); static HashSymbol *typeVariable(PrattParser *); static PrattRecord *fetchRecord(PrattParser *, HashSymbol *); static PrattTrie *makePrattTrie(PrattParser *, PrattTrie *); -static PrattUnicode *rawString(PrattParser *); -static PrattUnicode *str(PrattParser *); +static WCharArray *rawString(PrattParser *); +static WCharArray *str(PrattParser *); static void storeNameSpace(PrattParser *, AstNameSpace *); static void synchronize(PrattParser *parser); static PrattExportedOps *captureNameSpaceOperatorExports(PrattParser *parser); @@ -203,9 +203,25 @@ void disablePrattDebug(void) { DEBUGGING_OFF(); } static PrattParsers *parserStack = NULL; static PrattNsOpsArray *nsOpsCache = NULL; -static HashSymbol *unicodeToSymbol(PrattUnicode *unicode) { +/** + * Create a file id from a fileName. + * + * @param fileName the fileName + * @return the agnostic file id, or NULL if the file does not exist + */ +FileId *makeFileId(SCharVec *mbStr) { + struct stat stats; + if (stat(mbStr->entries, &stats) == 0) { + FileId *res = newFileId(stats.st_dev, stats.st_ino, mbStr); + return res; + } else { + return NULL; + } +} + +static HashSymbol *unicodeToSymbol(WCharArray *unicode) { size_t len = wcstombs(NULL, unicode->entries, 0); - PrattCVec *mbStr = newPrattCVec(len + 1); + SCharVec *mbStr = newSCharVec(len + 1); int save = PROTECT(mbStr); wcstombs(mbStr->entries, unicode->entries, len + 1); HashSymbol *res = newSymbol(mbStr->entries); @@ -256,11 +272,11 @@ static void addRecord(PrattRecordTable *table, HashSymbol *tok, PrattRecord *record = newPrattRecord( tok, (PrattFixityConfig){prefix, prefixPrec * PRECEDENCE_SCALE, NULL, NULL, - false, false, NULL, -1, NULL}, + false, false, NULL, false, -1, NULL}, (PrattFixityConfig){infix, infixPrec * PRECEDENCE_SCALE, NULL, NULL, - false, false, NULL, -1, NULL}, + false, false, NULL, false, -1, NULL}, (PrattFixityConfig){postfix, postfixPrec * PRECEDENCE_SCALE, NULL, NULL, - false, false, NULL, -1, NULL}); + false, false, NULL, false, -1, NULL}); int save = PROTECT(record); setPrattRecordTable(table, record->symbol, record); UNPROTECT(save); @@ -287,6 +303,7 @@ static PrattParser *makePrattParser(void) { addRecord(table, TOK_COMMA(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_ELSE(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_EOF(), NULL, 0, NULL, 0, NULL, 0); + addRecord(table, TOK_EQ(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_ERROR(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_EXPORT(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_FN(), fn, 0, NULL, 0, NULL, 0); @@ -300,8 +317,8 @@ static PrattParser *makePrattParser(void) { addRecord(table, TOK_LCURLY(), nestExpr, 0, makeStruct, 0, NULL, 0); addRecord(table, TOK_LET(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_LINK(), NULL, 0, NULL, 0, NULL, 0); + addRecord(table, TOK_LAZY(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_LSQUARE(), list, 0, NULL, 0, NULL, 0); - addRecord(table, TOK_MACRO(), macro, 0, NULL, 0, NULL, 0); addRecord(table, TOK_NAMESPACE(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_NUMBER(), makeNumber, 0, NULL, 0, NULL, 0); addRecord(table, TOK_OPEN(), grouping, 0, call, 14, NULL, 0); @@ -349,27 +366,24 @@ makeAstCompositeFunction(AstAltFunction *functions, } /** - * @brief Try to create an AgnosticFileId from a prefix and a file name. + * @brief Try to create a FileId from a prefix and a file name. * * This function constructs a file path by concatenating the prefix and file - * name, and then attempts to create an AgnosticFileId from that path. If the - * AgnosticFileId creation fails, it frees the allocated buffer. + * name, and then attempts to create a FileId from that path. If the + * FileId creation fails, it frees the allocated buffer. * * @param prefix The prefix path to prepend to the file name. * @param file The file name to append to the prefix. - * @return A pointer to the AgnosticFileId if successful, or NULL if the file + * @return A pointer to the FileId if successful, or NULL if the file * does not exist. */ -static AgnosticFileId *tryFile(char *prefix, char *file) { - char *buf = malloc(sizeof(char) * (strlen(prefix) + 1 + strlen(file) + 10)); - if (buf == NULL) { - perror("out of memory"); - exit(1); - } - sprintf(buf, "%s/%s", prefix, file); - AgnosticFileId *result = makeAgnosticFileId(buf); - if (result == NULL) - free(buf); +static FileId *tryFile(SCharVec *prefix, SCharVec *file) { + SCharVec *mbStr = newSCharVec(prefix->size + file->size); // assumes null + // terminator + int save = PROTECT(mbStr); + sprintf(mbStr->entries, "%s/%s", prefix->entries, file->entries); + FileId *result = makeFileId(mbStr); + UNPROTECT(save); return result; } @@ -381,78 +395,100 @@ static AgnosticFileId *tryFile(char *prefix, char *file) { * * @param initialPrefix The initial prefix to use for the search. * @param fileToFind The name of the file to search for. - * @return A pointer to the AgnosticFileId if found, or NULL if not found. + * @return A pointer to the FileId if found, or NULL if not found. */ -static AgnosticFileId *searchForFile(char *initialPrefix, char *fileToFind) { - AgnosticFileId *result = NULL; +static FileId *searchForFile(SCharVec *initialPrefix, SCharVec *fileToFind) { + FileId *result = NULL; result = tryFile(initialPrefix, fileToFind); if (result != NULL) return result; if (include_paths != NULL) { for (Index i = 0; i < include_paths->size; i++) { - result = tryFile(include_paths->entries[i], fileToFind); - if (result != NULL) + SCharVec *vec = stringToSCharVec(include_paths->entries[i]); + int save = PROTECT(vec); + result = tryFile(vec, fileToFind); + UNPROTECT(save); + if (result != NULL) { return result; + } } } return NULL; } +static SCharVec *symbolToVec(HashSymbol *symbol) { + size_t len = strlen(symbol->name); + SCharVec *mbStr = newSCharVec(len + 1); + int save = PROTECT(mbStr); + strcpy(mbStr->entries, symbol->name); + UNPROTECT(save); + return mbStr; +} + /** * @brief Get the current file name from the parser's lexer. * * @param parser The PrattParser. * @return The name of the current file, or "no_file" if not available. */ -static char *currentPrattFile(PrattParser *parser) { - char *no_file = "no_file"; +static SCharVec *currentPrattFile(PrattParser *parser) { if (parser == NULL) - return no_file; + return NULL; if (parser->lexer == NULL) - return no_file; + return NULL; if (parser->lexer->bufList == NULL) - return no_file; - return parser->lexer->bufList->fileName->name; + return NULL; + return symbolToVec(parser->lexer->bufList->fileName); } /** * @brief Calculate the path for a file based on the current parser's context. */ -static AgnosticFileId *calculatePath(unsigned char *file, PrattParser *parser) { - if (*file == '/') { - // Take ownership of the fileName by duplicating it so the - // AgnosticFileId can free it during GC finalization. - return makeAgnosticFileId(safeStrdup((char *)file)); +static FileId *calculatePath(SCharVec *file, PrattParser *parser) { + if (*file->entries == '/') { + return makeFileId(file); } - char *currentFile = currentPrattFile(parser); + FileId *result = NULL; + SCharVec *dot = newSCharVec(2); + int save = PROTECT(dot); + strcpy(dot->entries, "."); + SCharVec *currentFile = currentPrattFile(parser); if (currentFile == NULL) { - return searchForFile(".", (char *)file); + result = searchForFile(dot, file); + UNPROTECT(save); + return result; } - currentFile = strdup(currentFile); - char *slash = strrchr(currentFile, '/'); + PROTECT(currentFile); + char *slash = strrchr(currentFile->entries, '/'); if (slash == NULL) { - free(currentFile); - return searchForFile(".", (char *)file); + result = searchForFile(dot, file); + UNPROTECT(save); + return result; } - *slash = '\0'; - AgnosticFileId *result = searchForFile(currentFile, (char *)file); - free(currentFile); + // *slash = '\0'; + size_t prefixLen = slash - currentFile->entries; + SCharVec *prefix = newSCharVec(prefixLen + 1); + PROTECT(prefix); + strncpy(prefix->entries, currentFile->entries, prefixLen); + prefix->entries[prefixLen] = '\0'; + result = searchForFile(prefix, file); + UNPROTECT(save); return result; } /** * @brief Check if a file ID is already in the file ID stack. * - * This function checks if the given AgnosticFileId is already present in the + * This function checks if the given FileId is already present in the * AstFileIdArray. * - * @param id The AgnosticFileId to check. + * @param id The FileId to check. * @param array The AstFileIdArray to search in. * @return true if the file ID is found, false otherwise. */ -static bool fileIdInArray(AgnosticFileId *id, AstFileIdArray *array) { +static bool fileIdInArray(FileId *id, AstFileIdArray *array) { for (Index i = 0; i < array->size; ++i) { - if (cmpAgnosticFileId(id, array->entries[i]) == CMP_EQ) + if (eqFileId(id, array->entries[i])) return true; } return false; @@ -473,7 +509,7 @@ static void synchronize(PrattParser *parser) { return; if (check(parser, TOK_FN())) return; - if (check(parser, TOK_MACRO())) + if (check(parser, TOK_LAZY())) return; if (check(parser, TOK_IF())) return; @@ -729,8 +765,8 @@ static PrattExportedOps *captureNameSpaceOperatorExports(PrattParser *parser) { while ((sym = iteratePrattRecordTable(parser->rules, &i, &rec)) != NULL) { if (!(rec->prefix.export || rec->infix.export || rec->postfix.export)) continue; - static PrattFixityConfig emptyConfig = {NULL, 0, NULL, NULL, false, - false, NULL, -1, NULL}; + static PrattFixityConfig emptyConfig = {NULL, 0, NULL, NULL, false, + false, NULL, false, -1, NULL}; PrattFixityConfig prefixCfg = rec->prefix.export ? rec->prefix : emptyConfig; PrattFixityConfig infixCfg = @@ -750,8 +786,8 @@ static PrattRecord *ensureTargetRecord(PrattParser *parser, HashSymbol *op) { PrattRecord *target = NULL; if (!getPrattRecordTable(parser->rules, op, &target) || target == NULL) { // Create a blank record so we can import individual fixities - PrattFixityConfig empty = {NULL, 0, NULL, NULL, false, - false, NULL, -1, NULL}; + PrattFixityConfig empty = {NULL, 0, NULL, NULL, false, + false, NULL, false, -1, NULL}; target = newPrattRecord(op, empty, empty, empty); int save = PROTECT(target); setPrattRecordTable(parser->rules, op, target); @@ -775,6 +811,7 @@ static inline void mergeFixity(PrattParser *parser, PrattFixityConfig *target, target->op = source->op; target->importNsRef = nsRef; target->importNsSymbol = nsSymbol; + target->isLazy = source->isLazy; // Add secondary keywords to importing parser's trie if (source->pattern != NULL) { for (Index i = 1; i < source->pattern->keywords->size; ++i) { @@ -838,13 +875,13 @@ static void mergeFixityImport(PrattParser *parser, PrattRecord *target, * @param symbol The HashSymbol representing the nameSpace symbol. * @return An AstNameSpace containing the parsed nameSpace or an error. */ -static AstNameSpace *parseLink(PrattParser *parser, unsigned char *fileName, +static AstNameSpace *parseLink(PrattParser *parser, SCharVec *fileName, HashSymbol *symbol) { // check the file exists - AgnosticFileId *fileId = calculatePath(fileName, parser); + FileId *fileId = calculatePath(fileName, parser); int save = PROTECT(fileId); if (fileId == NULL) { - parserError(parser, "cannot find file \"%s\"", fileName); + parserError(parser, "cannot find file \"%s\"", fileName->entries); AstNameSpace *ns = newAstNameSpace(BUFPI(parser->lexer->bufList), symbol, -1); UNPROTECT(save); @@ -860,7 +897,8 @@ static AstNameSpace *parseLink(PrattParser *parser, unsigned char *fileName, } // check for a recursive include if (fileIdInArray(fileId, fileIdStack)) { - parserError(parser, "recursive include detected for %s", fileId->name); + parserError(parser, "recursive include detected for %s", + fileId->fileName->entries); AstNameSpace *ns = newAstNameSpace(BUFPI(parser->lexer->bufList), symbol, -1); UNPROTECT(save); @@ -873,10 +911,10 @@ static AstNameSpace *parseLink(PrattParser *parser, unsigned char *fileName, // careful, 2 pushes in a row could realloc the save stack on push 1 int save2 = PROTECT(fileId); AstDefinitions *definitions = - prattParseLink(parser, fileId->name, &resultParser); + prattParseLink(parser, fileId->fileName->entries, &resultParser); REPLACE_PROTECT(save2, resultParser); PROTECT(definitions); - // save the new nameSpace and it's parser + // save the new nameSpace and its parser AstNameSpaceImpl *impl = newAstNameSpaceImpl(BUFPI(parser->lexer->bufList), fileId, definitions); PROTECT(impl); @@ -1179,9 +1217,9 @@ static AstDefinitions *definitions(PrattParser *parser, HashSymbol *terminal) { * - It cannot contain whitespace. * * @param parser The PrattParser to report errors to. - * @param operator The PrattUnicode operator string to validate. + * @param operator The WCharArray operator string to validate. */ -static bool validateOperator(PrattParser *parser, PrattUnicode *operator) { +static bool validateOperator(PrattParser *parser, WCharArray *operator) { if (wcslen(operator->entries) == 0) { parserError(parser, "operator cannot be empty string"); return false; @@ -1249,7 +1287,7 @@ static AstExpressions *makeAstAarglist(ParserInfo PI, char *name, } /** - * @brief Generate a hygienic operator macro body. + * @brief Generate a hygienic operator lazy body. */ static AstDefinition *makeHygenicOperatorBody(ParserInfo PI, HashSymbol *symbol, AstFargList *fargs, @@ -1265,18 +1303,18 @@ static AstDefinition *makeHygenicOperatorBody(ParserInfo PI, HashSymbol *symbol, PROTECT(body); AstAltFunction *altFun = newAstAltFunction(PI, altArgs, body); PROTECT(altFun); - // Generate a macro instead of a function - // This creates: macro symbol(x, y) { impl(x, y) } - AstDefinition *res = makeAstDefinition_Macro(PI, symbol, altFun); + // Generate a lazy instead of a function + // This creates: lazy fn symbol(x, y) { impl(x, y) } + AstDefinition *res = makeAstDefinition_Lazy(PI, symbol, altFun); // Unprotect all in one go UNPROTECT(save); return res; } -static inline HashSymbol *makeMacroName() { return genSymDollar("opMacro"); } +static inline HashSymbol *makeLazyName() { return genSymDollar("opLazy"); } static AstDefinition *makeHygienicNaryOperatorDef(ParserInfo PI, int arity, - HashSymbol *macroName, + HashSymbol *lazyName, AstExpression *impl) { char buffer[32]; // make the formal argument list () @@ -1292,9 +1330,9 @@ static AstDefinition *makeHygienicNaryOperatorDef(ParserInfo PI, int arity, PROTECT(callArgs); arity--; } - // make the macro definition + // make the lazy definition AstDefinition *res = - makeHygenicOperatorBody(PI, macroName, argList, callArgs, impl); + makeHygenicOperatorBody(PI, lazyName, argList, callArgs, impl); UNPROTECT(save); return res; } @@ -1312,12 +1350,13 @@ static AstDefinition *makeHygienicNaryOperatorDef(ParserInfo PI, int arity, * @param associativity The associativity type of the operator (left, right, * none). * @param precedence The precedence level of the operator. - * @param operator The PrattUnicode representation of the operator. + * @param operator The WCharArray representation of the operator. * @param impl The AstExpression implementation of the operator. */ static AstDefinition *addOperator(PrattParser *parser, PrattFixity fixity, PrattAssoc associativity, int precedence, - PrattUnicode *operator, AstExpression *impl) { + WCharArray *operator, AstExpression *impl, + bool isLazy) { HashSymbol *op = unicodeToSymbol(operator); // Only look for an existing operator in the current (local) parser scope. // This allows inner scopes to shadow operators defined in outer scopes. @@ -1329,12 +1368,12 @@ static AstDefinition *addOperator(PrattParser *parser, PrattFixity fixity, record = copyPrattRecord(record); PROTECT(record); } else { - PrattFixityConfig empty = {NULL, 0, NULL, NULL, false, - false, NULL, -1, NULL}; + PrattFixityConfig empty = {NULL, 0, NULL, NULL, false, + false, NULL, false, -1, NULL}; record = newPrattRecord(op, empty, empty, empty); PROTECT(record); } - HashSymbol *hygienicFunc = makeMacroName(); + HashSymbol *hygienicFunc = makeLazyName(); bool isBareSymbol = (impl && impl->type == AST_EXPRESSION_TYPE_SYMBOL); int scaledPrec = precedence * PRECEDENCE_SCALE; AstDefinition *def = NULL; @@ -1348,7 +1387,13 @@ static AstDefinition *addOperator(PrattParser *parser, PrattFixity fixity, } fixityConfig = &record->prefix; fixityConfig->op = userPrefix; - def = makeHygienicNaryOperatorDef(CPI(impl), 1, hygienicFunc, impl); + if (isLazy) { + def = makeHygienicNaryOperatorDef(CPI(impl), 1, hygienicFunc, impl); + } else if (isBareSymbol) { + def = newAstDefinition_Blank(CPI(impl)); + } else { + def = makeAstDefinition_Define(CPI(impl), hygienicFunc, impl); + } } break; case PRATTFIXITY_TYPE_INFIX: { if (record->infix.op) { @@ -1366,7 +1411,13 @@ static AstDefinition *addOperator(PrattParser *parser, PrattFixity fixity, (associativity == PRATTASSOC_TYPE_LEFT) ? userInfixLeft : (associativity == PRATTASSOC_TYPE_RIGHT) ? userInfixRight : userInfixNone; - def = makeHygienicNaryOperatorDef(CPI(impl), 2, hygienicFunc, impl); + if (isLazy) { + def = makeHygienicNaryOperatorDef(CPI(impl), 2, hygienicFunc, impl); + } else if (isBareSymbol) { + def = newAstDefinition_Blank(CPI(impl)); + } else { + def = makeAstDefinition_Define(CPI(impl), hygienicFunc, impl); + } } break; case PRATTFIXITY_TYPE_POSTFIX: { if (record->postfix.op) { @@ -1381,7 +1432,13 @@ static AstDefinition *addOperator(PrattParser *parser, PrattFixity fixity, } fixityConfig = &record->postfix; fixityConfig->op = userPostfix; - def = makeHygienicNaryOperatorDef(CPI(impl), 1, hygienicFunc, impl); + if (isLazy) { + def = makeHygienicNaryOperatorDef(CPI(impl), 1, hygienicFunc, impl); + } else if (isBareSymbol) { + def = newAstDefinition_Blank(CPI(impl)); + } else { + def = makeAstDefinition_Define(CPI(impl), hygienicFunc, impl); + } } break; default: cant_happen("unknown fixity type %s", prattFixityName(fixity)); @@ -1392,6 +1449,7 @@ static AstDefinition *addOperator(PrattParser *parser, PrattFixity fixity, fixityConfig->originalImpl = impl; fixityConfig->hygienicFunc = hygienicFunc; fixityConfig->isBareSymbol = isBareSymbol; + fixityConfig->isLazy = isLazy; if (isNewOperator) { parser->trie = insertPrattTrie(parser->trie, op); } @@ -1451,7 +1509,7 @@ AstExpression *userMixfix(PrattRecord *record, PrattParser *parser, arity--; if (arity > 0 || !(pattern->endsWithHole)) { // Consume the next keyword - PrattUnicode *kw = keywords->entries[kwIndex++]; + WCharArray *kw = keywords->entries[kwIndex++]; PrattToken *nextTok = peek(parser); HashSymbol *nextSym = unicodeToSymbol(kw); if (!isAtomSymbol(nextTok, nextSym)) { @@ -1474,6 +1532,7 @@ AstExpression *userMixfix(PrattRecord *record, PrattParser *parser, // implementation AstExpression *func = makeAstExpression_AnnotatedSymbol( TOKPI(tok), fixityConfig->hygienicFunc, fixityConfig->originalImpl); + getAstExpression_AnnotatedSymbol(func)->isLazy = fixityConfig->isLazy; PROTECT(func); if (fixityConfig->importNsRef >= 0) { func = makeAstExpression_LookUp(TOKPI(tok), fixityConfig->importNsRef, @@ -1533,7 +1592,8 @@ static AstExpression *userPostfixMix(PrattRecord *record, PrattParser *parser, static AstDefinition *addMixfixOperator(PrattParser *parser, PrattMixfixPattern *pattern, PrattAssoc associativity, - int precedence, AstExpression *impl) { + int precedence, AstExpression *impl, + bool isLazy) { // Add secondary keywords to trie (no conflict check - precedence handles // disambiguation) for (Index i = 1; i < pattern->keywords->size; ++i) { @@ -1541,9 +1601,9 @@ static AstDefinition *addMixfixOperator(PrattParser *parser, parser->trie = insertPrattTrie(parser->trie, inner); } PrattFixity fixity = getFixityFromPattern(pattern); - PrattUnicode *operator = pattern->keywords->entries[0]; - (void)addOperator(parser, fixity, associativity, precedence, operator, - impl); + WCharArray *operator = pattern->keywords->entries[0]; + (void)addOperator(parser, fixity, associativity, precedence, operator, impl, + isLazy); HashSymbol *op = unicodeToSymbol(operator); // Store the mixfix pattern in the PrattRecord for later parsing PrattRecord *record = NULL; @@ -1552,8 +1612,15 @@ static AstDefinition *addMixfixOperator(PrattParser *parser, switch (fixity) { case PRATTFIXITY_TYPE_PREFIX: record->prefix.op = userPrefixMix; - def = makeHygienicNaryOperatorDef(CPI(impl), pattern->arity, - record->prefix.hygienicFunc, impl); + if (isLazy) { + def = makeHygienicNaryOperatorDef( + CPI(impl), pattern->arity, record->prefix.hygienicFunc, impl); + } else if (record->prefix.isBareSymbol) { + def = newAstDefinition_Blank(CPI(impl)); + } else { + def = makeAstDefinition_Define(CPI(impl), + record->prefix.hygienicFunc, impl); + } if (record->prefix.pattern != NULL) { parserErrorAt(CPI(impl), parser, "attempt to redefine mixfix operator \"%ls\"", @@ -1563,8 +1630,15 @@ static AstDefinition *addMixfixOperator(PrattParser *parser, break; case PRATTFIXITY_TYPE_INFIX: record->infix.op = userInfixMix; - def = makeHygienicNaryOperatorDef(CPI(impl), pattern->arity, - record->infix.hygienicFunc, impl); + if (isLazy) { + def = makeHygienicNaryOperatorDef(CPI(impl), pattern->arity, + record->infix.hygienicFunc, impl); + } else if (record->infix.isBareSymbol) { + def = newAstDefinition_Blank(CPI(impl)); + } else { + def = makeAstDefinition_Define(CPI(impl), + record->infix.hygienicFunc, impl); + } if (record->infix.pattern != NULL) { parserErrorAt(CPI(impl), parser, "attempt to redefine mixfix operator \"%ls\"", @@ -1574,8 +1648,15 @@ static AstDefinition *addMixfixOperator(PrattParser *parser, break; case PRATTFIXITY_TYPE_POSTFIX: record->postfix.op = userPostfixMix; - def = makeHygienicNaryOperatorDef(CPI(impl), pattern->arity, - record->postfix.hygienicFunc, impl); + if (isLazy) { + def = makeHygienicNaryOperatorDef( + CPI(impl), pattern->arity, record->postfix.hygienicFunc, impl); + } else if (record->postfix.isBareSymbol) { + def = newAstDefinition_Blank(CPI(impl)); + } else { + def = makeAstDefinition_Define(CPI(impl), + record->postfix.hygienicFunc, impl); + } if (record->postfix.pattern != NULL) { parserErrorAt(CPI(impl), parser, "attempt to redefine mixfix operator \"%ls\"", @@ -1723,14 +1804,13 @@ static PrattParser *meldParsers(PrattParser *to, PrattParser *from) { } } -static PrattUnicode *prattUnicodeSubstr(PrattUnicode *str, Index start, - Index end) { - PrattUnicode *res = newPrattUnicode(); +static WCharArray *prattUnicodeSubstr(WCharArray *str, Index start, Index end) { + WCharArray *res = newWCharArray(); int save = PROTECT(res); for (Index i = start; i < end; i++) { - pushPrattUnicode(res, str->entries[i]); + pushWCharArray(res, str->entries[i]); } - pushPrattUnicode(res, '\0'); + pushWCharArray(res, '\0'); UNPROTECT(save); return res; } @@ -1774,7 +1854,7 @@ static int patternStateTable[11][3] = { }; static PrattMixfixPattern * -parseMixfixPattern(ParserInfo PI, PrattParser *parser, PrattUnicode *str) { +parseMixfixPattern(ParserInfo PI, PrattParser *parser, WCharArray *str) { // A mixfix pattern is a sequence of keywords and holes. // A hole is represented by an underscore character '_'. PrattStrings *strings = newPrattStrings(); @@ -1800,7 +1880,7 @@ parseMixfixPattern(ParserInfo PI, PrattParser *parser, PrattUnicode *str) { case PATTERN_STATE_C: break; case PATTERN_STATE_CU: { - PrattUnicode *kw = prattUnicodeSubstr(str, start, i); + WCharArray *kw = prattUnicodeSubstr(str, start, i); int save = PROTECT(kw); pushPrattStrings(strings, kw); UNPROTECT(save); @@ -1814,7 +1894,7 @@ parseMixfixPattern(ParserInfo PI, PrattParser *parser, PrattUnicode *str) { case PATTERN_STATE_UC: break; case PATTERN_STATE_UCU: { - PrattUnicode *kw = prattUnicodeSubstr(str, start, i); + WCharArray *kw = prattUnicodeSubstr(str, start, i); int save = PROTECT(kw); pushPrattStrings(strings, kw); UNPROTECT(save); @@ -1823,13 +1903,13 @@ parseMixfixPattern(ParserInfo PI, PrattParser *parser, PrattUnicode *str) { case PATTERN_STATE_CUF: break; case PATTERN_STATE_CCF: { - PrattUnicode *kw = prattUnicodeSubstr(str, start, i); + WCharArray *kw = prattUnicodeSubstr(str, start, i); int save = PROTECT(kw); pushPrattStrings(strings, kw); UNPROTECT(save); } break; case PATTERN_STATE_UCF: { - PrattUnicode *kw = prattUnicodeSubstr(str, start, i); + WCharArray *kw = prattUnicodeSubstr(str, start, i); int save = PROTECT(kw); pushPrattStrings(strings, kw); UNPROTECT(save); @@ -1885,7 +1965,8 @@ static PrattAssoc parseOptionalAssociativity(PrattParser *parser) { * for error reporting. */ static AstDefinition *operatorWithPattern(PrattParser *parser, PrattToken *tok, - PrattMixfixPattern *pattern) { + PrattMixfixPattern *pattern, + bool isLazy) { ENTER(operatorWithPattern); int save = PROTECT(tok); PROTECT(pattern); @@ -1920,7 +2001,7 @@ static AstDefinition *operatorWithPattern(PrattParser *parser, PrattToken *tok, AstExpression *impl = expression(parser); PROTECT(impl); AstDefinition *def = - addMixfixOperator(parser, pattern, assoc, precedence, impl); + addMixfixOperator(parser, pattern, assoc, precedence, impl, isLazy); LEAVE(operatorWithPattern); UNPROTECT(save); return def; @@ -1929,15 +2010,15 @@ static AstDefinition *operatorWithPattern(PrattParser *parser, PrattToken *tok, /** * Parse `operator [] ;` */ -static AstDefinition *operator(PrattParser *parser) { +static AstDefinition *operator(PrattParser *parser, bool isLazy) { ENTER(operator); PrattToken *tok = peek(parser); int save = PROTECT(tok); - PrattUnicode *str = rawString(parser); + WCharArray *str = rawString(parser); PROTECT(str); PrattMixfixPattern *pattern = parseMixfixPattern(TOKPI(tok), parser, str); PROTECT(pattern); - AstDefinition *def = operatorWithPattern(parser, tok, pattern); + AstDefinition *def = operatorWithPattern(parser, tok, pattern, isLazy); LEAVE(operator); UNPROTECT(save); return def; @@ -1947,7 +2028,7 @@ static AstDefinition *operator(PrattParser *parser) { * @brief Parse a definition. * * This fuction parses a definition, which can be an assignment, - * a typedef, a function, a printer, a macro, a link, an alias, + * a typedef, a function, a printer, a lazy fn, a link, an alias, * a prefix, an infix, or a postfix operator. * * @param parser The PrattParser to use for parsing. @@ -1972,16 +2053,25 @@ static AstDefinition *definition(PrattParser *parser) { save = PROTECT(res); } else if (match(parser, TOK_UNSAFE())) { consume(parser, TOK_FN()); - res = defun(parser, true, false); + res = defun(parser, true, DEFUN_FUNCTION); save = PROTECT(res); } else if (match(parser, TOK_FN())) { - res = defun(parser, false, false); + res = defun(parser, false, DEFUN_FUNCTION); save = PROTECT(res); } else if (match(parser, TOK_PRINT())) { - res = defun(parser, false, true); + res = defun(parser, false, DEFUN_PRINTER); save = PROTECT(res); - } else if (match(parser, TOK_MACRO())) { - res = defMacro(parser); + } else if (match(parser, TOK_EQ())) { + res = defun(parser, false, DEFUN_COMPARATOR); + save = PROTECT(res); + } else if (match(parser, TOK_LAZY())) { + if (check(parser, TOK_OPERATOR())) { + match(parser, TOK_OPERATOR()); + res = operator(parser, true); + } else { + consume(parser, TOK_FN()); + res = defLazy(parser); + } save = PROTECT(res); } else if (match(parser, TOK_LINK())) { res = link(parser); @@ -1996,7 +2086,7 @@ static AstDefinition *definition(PrattParser *parser) { res = exportOp(parser); save = PROTECT(res); } else if (match(parser, TOK_OPERATOR())) { - res = operator(parser); + res = operator(parser, false); save = PROTECT(res); } else { PrattToken *tok = next(parser); @@ -2085,20 +2175,59 @@ static AstDefinition *exportOp(PrattParser *parser) { "expected 'operators' or a fixity after export"); res = newAstDefinition_Blank(TOKPI(atom)); } + } else if (match(parser, TOK_LAZY())) { + if (!match(parser, TOK_OPERATOR())) { + parserError(parser, "expected 'operator' after 'lazy' in export"); + LEAVE(exportOp); + UNPROTECT(save); + return newAstDefinition_Blank(TOKPI(tok)); + } + // export lazy operator ... + PrattToken *opTok = peek(parser); + PROTECT(opTok); + WCharArray *str = rawString(parser); + PROTECT(str); + PrattMixfixPattern *pattern = + parseMixfixPattern(TOKPI(opTok), parser, str); + PROTECT(pattern); + res = operatorWithPattern(parser, opTok, pattern, true); + PROTECT(res); + if (pattern != NULL) { + HashSymbol *op = unicodeToSymbol(pattern->keywords->entries[0]); + PrattRecord *rec = NULL; + if (!getPrattRecordTable(parser->rules, op, &rec) || rec == NULL) { + parserError(parser, + "cannot export non-local operator '%s' in pattern", + op->name); + } else { + PrattFixity fixity = getFixityFromPattern(pattern); + switch (fixity) { + case PRATTFIXITY_TYPE_PREFIX: + rec->prefix.export = true; + break; + case PRATTFIXITY_TYPE_INFIX: + rec->infix.export = true; + break; + case PRATTFIXITY_TYPE_POSTFIX: + rec->postfix.export = true; + break; + } + } + } } else if (match(parser, TOK_OPERATOR())) { // for export operator, the syntax includes the definition of the // operator: export operator [] // ; Parse the pattern string first PrattToken *opTok = peek(parser); PROTECT(opTok); - PrattUnicode *str = rawString(parser); + WCharArray *str = rawString(parser); PROTECT(str); PrattMixfixPattern *pattern = parseMixfixPattern(TOKPI(opTok), parser, str); PROTECT(pattern); // Now parse the operator definition using the already-parsed pattern - res = operatorWithPattern(parser, opTok, pattern); + res = operatorWithPattern(parser, opTok, pattern, false); PROTECT(res); // Mark the operator as exported @@ -2221,7 +2350,7 @@ static AstDefinition *importOp(PrattParser *parser) { } } else if (match(parser, TOK_OPERATOR())) { // import operator ; - PrattUnicode *str = rawString(parser); + WCharArray *str = rawString(parser); PROTECT(str); PrattMixfixPattern *pattern = parseMixfixPattern(TOKPI(tok), parser, str); @@ -2994,20 +3123,20 @@ static AstFarg *astExpressionToFarg(PrattParser *parser, AstExpression *expr) { } /** - * @brief validate that the macro arguments are conforming (symbols only, and no - * alternative args) + * @brief validate that the lazy fn arguments are conforming (symbols only, and + * no alternative args) */ -static void validateMacroArgs(PrattParser *parser, AstAltFunction *definition) { +static void validateLazyArgs(PrattParser *parser, AstAltFunction *definition) { AstAltArgs *altArgs = definition->altArgs; if (altArgs->next) { parserErrorAt(CPI(altArgs->next), parser, - "cannot supply alternative arguments to a macro"); + "cannot supply alternative arguments to a lazy fn"); } else { AstFargList *args = altArgs->argList; while (args) { if (args->arg->type != AST_FARG_TYPE_SYMBOL) { parserErrorAt(CPI(args->arg), parser, - "macro arguments can only be simple symbols"); + "lazy fn arguments can only be simple symbols"); break; } args = args->next; @@ -3016,20 +3145,21 @@ static void validateMacroArgs(PrattParser *parser, AstAltFunction *definition) { } /** - * @brief parse a macro definition. + * @brief parse a lazy fn definition. * - * the `macro` token has already been consumed when this function triggers. + * the `lazy` and `fn` tokens have already been consumed when this function + * triggers. */ -static AstDefinition *defMacro(PrattParser *parser) { - ENTER(defMacro); +static AstDefinition *defLazy(PrattParser *parser) { + ENTER(defLazy); PrattToken *tok = peek(parser); int save = PROTECT(tok); HashSymbol *s = symbol(parser); AstAltFunction *definition = altFunction(parser); PROTECT(definition); - validateMacroArgs(parser, definition); - AstDefinition *res = makeAstDefinition_Macro(TOKPI(tok), s, definition); - LEAVE(defMacro); + validateLazyArgs(parser, definition); + AstDefinition *res = makeAstDefinition_Lazy(TOKPI(tok), s, definition); + LEAVE(defLazy); UNPROTECT(save); return res; } @@ -3039,7 +3169,7 @@ static AstDefinition *defMacro(PrattParser *parser) { * * The `fn` token has already been consumed when this function is triggered. */ -static AstDefinition *defun(PrattParser *parser, bool unsafe, bool isPrinter) { +static AstDefinition *defun(PrattParser *parser, bool unsafe, DefunType type) { ENTER(defun); PrattToken *tok = peek(parser); int save = PROTECT(tok); @@ -3047,8 +3177,10 @@ static AstDefinition *defun(PrattParser *parser, bool unsafe, bool isPrinter) { AstCompositeFunction *f = compositeFunction(parser); f->unsafe = unsafe; PROTECT(f); - if (isPrinter) { + if (type == DEFUN_PRINTER) { s = makePrintName("print$", s->name); + } else if (type == DEFUN_COMPARATOR) { + s = makePrintName("eq$", s->name); } AstExpression *expr = newAstExpression_Fun(CPI(f), f); PROTECT(expr); @@ -3101,7 +3233,7 @@ static AstDefinition *assignment(PrattParser *parser) { return res; } -static AstSymbolList *symbolList(PrattParser *parser) { +static AstSymbolList *symbolList(PrattParser *parser, bool allowWildcard) { ENTER(symbolList); if (match(parser, TOK_CLOSE())) { LEAVE(symbolList); @@ -3112,13 +3244,15 @@ static AstSymbolList *symbolList(PrattParser *parser) { HashSymbol *s = NULL; if (symbol->type == TOK_ATOM()) { s = symbol->value->val.atom; + } else if (allowWildcard && symbol->type == TOK_WILDCARD()) { + s = TOK_WILDCARD(); } else { parserError(parser, "expected ATOM, got %s", symbol->type->name); s = TOK_ERROR(); } AstSymbolList *this = NULL; if (match(parser, TOK_COMMA())) { - AstSymbolList *rest = symbolList(parser); + AstSymbolList *rest = symbolList(parser, allowWildcard); PROTECT(rest); this = newAstSymbolList(TOKPI(symbol), s, rest); } else { @@ -3137,7 +3271,7 @@ static AstDefinition *multiDefinition(PrattParser *parser) { ENTER(multiDefinition); PrattToken *tok = peek(parser); int save = PROTECT(tok); - AstSymbolList *symbols = symbolList(parser); + AstSymbolList *symbols = symbolList(parser, true); PROTECT(symbols); consume(parser, TOK_ASSIGN()); AstExpression *expr = expression(parser); @@ -3259,7 +3393,7 @@ static AstTypeSymbols *typeVariables(PrattParser *parser) { */ static AstDefinition *link(PrattParser *parser) { ENTER(link); - PrattUnicode *path = rawString(parser); + WCharArray *path = rawString(parser); int save = PROTECT(path); AstDefinition *res = NULL; if (path == NULL) { @@ -3269,11 +3403,10 @@ static AstDefinition *link(PrattParser *parser) { HashSymbol *name = symbol(parser); // Convert wide character path to multibyte size_t len = wcstombs(NULL, path->entries, 0); - PrattCVec *mbPath = newPrattCVec(len + 1); + SCharVec *mbPath = newSCharVec(len + 1); PROTECT(mbPath); wcstombs(mbPath->entries, path->entries, len + 1); - AstNameSpace *ns = - parseLink(parser, (unsigned char *)mbPath->entries, name); + AstNameSpace *ns = parseLink(parser, mbPath, name); PROTECT(ns); storeNameSpace(parser, ns); res = newAstDefinition_Blank(CPI(ns)); @@ -3286,7 +3419,7 @@ static AstDefinition *link(PrattParser *parser) { /** * @brief parses a raw double-quoted string for a link directive. */ -static PrattUnicode *rawString(PrattParser *parser) { +static WCharArray *rawString(PrattParser *parser) { ENTER(rawString); PrattToken *tok = next(parser); validateLastAlloc(); @@ -3300,9 +3433,9 @@ static PrattUnicode *rawString(PrattParser *parser) { return tok->value->val.string; } else { parserError(parser, "expected string, got %s", tok->type->name); - PrattUnicode *err = newPrattUnicode(); + WCharArray *err = newWCharArray(); int save = PROTECT(err); - pushPrattUnicode(err, 0); + pushWCharArray(err, 0); LEAVE(rawString); UNPROTECT(save); return err; @@ -3312,13 +3445,13 @@ static PrattUnicode *rawString(PrattParser *parser) { /** * @brief parses a subsequent string, appending it to the current. */ -static void appendString(PrattParser *parser, PrattUnicode *this) { +static void appendString(PrattParser *parser, WCharArray *this) { ENTER(appendString); - PrattUnicode *next = rawString(parser); + WCharArray *next = rawString(parser); int save = PROTECT(next); this->size--; // backup over '\0' for (Index i = 0; i < next->size; i++) { - pushPrattUnicode(this, next->entries[i]); + pushWCharArray(this, next->entries[i]); } UNPROTECT(save); if (check(parser, TOK_STRING())) { @@ -3330,9 +3463,9 @@ static void appendString(PrattParser *parser, PrattUnicode *this) { /** * @brief parses any sequence of adjacent strings into a single string. */ -static PrattUnicode *str(PrattParser *parser) { +static WCharArray *str(PrattParser *parser) { ENTER(str); - PrattUnicode *this = rawString(parser); + WCharArray *this = rawString(parser); int save = PROTECT(this); if (check(parser, TOK_STRING())) { appendString(parser, this); @@ -3797,21 +3930,6 @@ static AstExpression *unsafe(PrattRecord *record __attribute__((unused)), return expr; } -/** - * @brief parselet triggered by a prefix `macro` token. - * - * We can't actually allow anonymous macro expressions but need to ensure - * `macro` is registered as a prefix operator so that it can't be - * overridden. - */ -static AstExpression *macro(PrattRecord *record __attribute__((unused)), - PrattParser *parser, - AstExpression *lhs __attribute__((unused)), - PrattToken *tok) { - parserErrorAt(TOKPI(tok), parser, "can't declare macros as expressions"); - return errorExpression(TOKPI(tok)); -} - /** * @brief parselet triggered by a prefix `fn` token. */ @@ -3943,6 +4061,7 @@ static AstExpression *userPrefix(PrattRecord *record, PrattParser *parser, // implementation AstExpression *func = makeAstExpression_AnnotatedSymbol( TOKPI(tok), record->prefix.hygienicFunc, record->prefix.originalImpl); + getAstExpression_AnnotatedSymbol(func)->isLazy = record->prefix.isLazy; PROTECT(func); if (record->prefix.importNsRef >= 0) { func = makeAstExpression_LookUp(TOKPI(tok), record->prefix.importNsRef, @@ -3979,6 +4098,7 @@ static AstExpression *userInfixCommon(PrattRecord *record, PrattParser *parser, // implementation AstExpression *func = makeAstExpression_AnnotatedSymbol( TOKPI(tok), record->infix.hygienicFunc, record->infix.originalImpl); + getAstExpression_AnnotatedSymbol(func)->isLazy = record->infix.isLazy; PROTECT(func); if (record->infix.importNsRef >= 0) { func = makeAstExpression_LookUp(TOKPI(tok), record->infix.importNsRef, @@ -4051,6 +4171,7 @@ static AstExpression *userPostfix(PrattRecord *record, // implementation AstExpression *func = makeAstExpression_AnnotatedSymbol( TOKPI(tok), record->postfix.hygienicFunc, record->postfix.originalImpl); + getAstExpression_AnnotatedSymbol(func)->isLazy = record->postfix.isLazy; PROTECT(func); if (record->postfix.importNsRef >= 0) { func = makeAstExpression_LookUp(TOKPI(tok), record->postfix.importNsRef, @@ -4163,7 +4284,7 @@ static AstExpression *makeChar(PrattRecord *record __attribute__((unused)), /** * @brief utility to convert a string to a nested list of conses of characters. */ -static AstFunCall *makeStringList(ParserInfo PI, PrattUnicode *str) { +static AstFunCall *makeStringList(ParserInfo PI, WCharArray *str) { AstExpression *nil = newAstExpression_Symbol(PI, nilSymbol()); int save = PROTECT(nil); AstFunCall *res = newAstFunCall(PI, nil, NULL); @@ -4205,7 +4326,7 @@ static AstExpression *makeString(PrattRecord *record __attribute__((unused)), } #endif enqueueToken(parser->lexer, tok); - PrattUnicode *uni = str(parser); + WCharArray *uni = str(parser); int save = PROTECT(uni); AstFunCall *list = makeStringList(TOKPI(tok), uni); PROTECT(list); diff --git a/src/pratt_parser.h b/src/pratt_parser.h index 6820e5e9..e5c47ddb 100644 --- a/src/pratt_parser.h +++ b/src/pratt_parser.h @@ -21,12 +21,13 @@ #include "ast.h" #include "common.h" #include "pratt.h" +#include "utils.h" #ifdef DEBUG_PRATT_PARSER void disablePrattDebug(void); #endif -void ppAstNest(AstUTF8 *, AstNest *); -void ppAstProg(AstUTF8 *, AstProg *); +void ppAstNest(SCharArray *, AstNest *); +void ppAstProg(SCharArray *, AstProg *); int initFileIdStack(void); int initParserStack(void); int initNsOpsCache(void); diff --git a/src/pratt_scanner.c b/src/pratt_scanner.c index 24c55c92..e9b67c5f 100644 --- a/src/pratt_scanner.c +++ b/src/pratt_scanner.c @@ -63,6 +63,7 @@ TOKFN(COLON, ":") TOKFN(COMMA, ",") TOKFN(ELSE, "else") TOKFN(EOF, " EOF") +TOKFN(EQ, "EQ") TOKFN(ERROR, " ERROR") TOKFN(EXPORT, "export") TOKFN(FN, "fn") @@ -77,8 +78,8 @@ TOKFN(LCURLY, "{") TOKFN(LEFT, "left") TOKFN(LET, "let") TOKFN(LINK, "link") +TOKFN(LAZY, "lazy") TOKFN(LSQUARE, "[") -TOKFN(MACRO, "macro") TOKFN(NAMESPACE, "namespace") TOKFN(NONE, "none") TOKFN(NUMBER, " NUMBER") @@ -138,14 +139,15 @@ void parserError(PrattParser *parser, const char *message, ...) { return; parser->panicMode = true; va_start(args, message); - vfprintf(errout, message, args); - va_end(args); PrattBufList *bufList = parser->lexer->bufList; if (bufList) { - can_happen(" at +%d %s", bufList->lineNo, bufList->fileName->name); + ParserInfo pi = {.lineNo = bufList->lineNo, + .fileName = bufList->fileName->name}; + vcan_happen(pi, message, args); } else { - can_happen(" at EOF"); + vcan_happen(NULLPI, message, args); } + va_end(args); } /** @@ -160,12 +162,11 @@ void parserErrorAt(ParserInfo PI, PrattParser *parser, const char *message, return; parser->panicMode = true; va_start(args, message); - vfprintf(errout, message, args); + vcan_happen(PI, message, args); va_end(args); - can_happen(" at +%d %s", PI.lineNo, PI.fileName); } -static PrattCVec *readFileBytes(char *path) { +static SCharVec *readFileBytes(char *path) { FILE *file = fopen(path, "rb"); if (file == NULL) { perror(path); // FIXME shouldn't need to exit here @@ -174,7 +175,7 @@ static PrattCVec *readFileBytes(char *path) { fseek(file, 0L, SEEK_END); size_t fileSize = ftell(file); rewind(file); - PrattCVec *bytes = newPrattCVec(fileSize + 1); + SCharVec *bytes = newSCharVec(fileSize + 1); int save = PROTECT(bytes); size_t bytes_read = fread(bytes->entries, sizeof(char), fileSize, file); bytes->entries[bytes_read] = '\0'; @@ -186,18 +187,18 @@ static PrattCVec *readFileBytes(char *path) { /** * @brief Reads the contents of a file into a dynamically allocated string. */ -static PrattWVec *readFile(char *path) { - PrattCVec *bytes = readFileBytes(path); +static WCharVec *readFile(char *path) { + SCharVec *bytes = readFileBytes(path); int save = PROTECT(bytes); size_t wideSize = mbstowcs(NULL, bytes->entries, 0); if (wideSize == (size_t)-1) { - can_happen("invalid encoding in file %s", path); - PrattWVec *data = newPrattWVec(1); + can_happen(NULLPI, "invalid encoding in file %s", path); + WCharVec *data = newWCharVec(1); data->entries[0] = L'\0'; UNPROTECT(save); return data; } - PrattWVec *data = newPrattWVec(wideSize + 1); + WCharVec *data = newWCharVec(wideSize + 1); PROTECT(data); mbstowcs(data->entries, bytes->entries, wideSize + 1); UNPROTECT(save); @@ -262,9 +263,9 @@ static PrattToken *tokenFromBigInt(PrattBufList *bufList, MaybeBigInt *bi, return token; } -static PrattCVec *wVecToCVec(PrattWVec *wvec) { +static SCharVec *wVecToCVec(WCharVec *wvec) { size_t needed = wcstombs(NULL, wvec->entries, 0); - PrattCVec *cvec = newPrattCVec(needed + 1); + SCharVec *cvec = newSCharVec(needed + 1); wcstombs(cvec->entries, wvec->entries, needed + 1); return cvec; } @@ -273,11 +274,11 @@ static PrattCVec *wVecToCVec(PrattWVec *wvec) { * @brief Converts a PrattBuffer to a HashSymbol. */ static HashSymbol *symbolFromBuffer(PrattBuffer *buffer) { - PrattWVec *data = newPrattWVec(buffer->offset + 1); + WCharVec *data = newWCharVec(buffer->offset + 1); int save = PROTECT(data); memcpy(data->entries, buffer->start, buffer->offset * sizeof(Character)); data->entries[buffer->offset] = L'\0'; - PrattCVec *bytes = wVecToCVec(data); + SCharVec *bytes = wVecToCVec(data); PROTECT(bytes); HashSymbol *symbol = newSymbol(bytes->entries); UNPROTECT(save); @@ -288,7 +289,7 @@ static HashSymbol *symbolFromBuffer(PrattBuffer *buffer) { * @brief Creates a new PrattToken from a string. * Uses the PrattBufList to provide ParserInfo context for the token. */ -static PrattToken *tokenFromString(PrattBufList *bufList, PrattUnicode *string, +static PrattToken *tokenFromString(PrattBufList *bufList, WCharArray *string, HashSymbol *tokenType) { PrattValue *value = newPrattValue_String(string); int save = PROTECT(value); @@ -716,7 +717,7 @@ static PrattToken *parseString(PrattParser *parser, bool parsingSingleChar, Character sep) { PrattLexer *lexer = parser->lexer; PrattBuffer *buffer = lexer->bufList->buffer; - PrattUnicode *string = newPrattUnicode(); + WCharArray *string = newWCharArray(); int save = PROTECT(string); PrattStringState state = PRATTSTRINGSTATE_TYPE_START; Character uni = 0; @@ -763,7 +764,7 @@ static PrattToken *parseString(PrattParser *parser, bool parsingSingleChar, state = PRATTSTRINGSTATE_TYPE_END; break; default: - pushPrattUnicode(string, buffer->start[buffer->offset]); + pushWCharArray(string, buffer->start[buffer->offset]); ++buffer->offset; state = parsingSingleChar ? PRATTSTRINGSTATE_TYPE_CHR : PRATTSTRINGSTATE_TYPE_STR; @@ -782,7 +783,7 @@ static PrattToken *parseString(PrattParser *parser, bool parsingSingleChar, state = PRATTSTRINGSTATE_TYPE_END; break; default: - pushPrattUnicode(string, buffer->start[buffer->offset]); + pushWCharArray(string, buffer->start[buffer->offset]); ++buffer->offset; state = parsingSingleChar ? PRATTSTRINGSTATE_TYPE_CHR : PRATTSTRINGSTATE_TYPE_STR; @@ -803,13 +804,13 @@ static PrattToken *parseString(PrattParser *parser, bool parsingSingleChar, state = PRATTSTRINGSTATE_TYPE_UNI; break; case L'n': - pushPrattUnicode(string, L'\n'); + pushWCharArray(string, L'\n'); ++buffer->offset; state = parsingSingleChar ? PRATTSTRINGSTATE_TYPE_CHR : PRATTSTRINGSTATE_TYPE_STR; break; case L't': - pushPrattUnicode(string, L'\t'); + pushWCharArray(string, L'\t'); ++buffer->offset; state = parsingSingleChar ? PRATTSTRINGSTATE_TYPE_CHR : PRATTSTRINGSTATE_TYPE_STR; @@ -874,7 +875,7 @@ static PrattToken *parseString(PrattParser *parser, bool parsingSingleChar, parserError(parser, "Empty Unicode escape while parsing string"); } else { - pushPrattUnicode(string, uni); + pushWCharArray(string, uni); } state = parsingSingleChar ? PRATTSTRINGSTATE_TYPE_CHR : PRATTSTRINGSTATE_TYPE_STR; @@ -908,7 +909,7 @@ static PrattToken *parseString(PrattParser *parser, bool parsingSingleChar, cant_happen("end state in loop"); } } - pushPrattUnicode(string, '\0'); + pushWCharArray(string, '\0'); PrattToken *token = tokenFromString( lexer->bufList, string, parsingSingleChar ? TOK_CHAR() : TOK_STRING()); advance(buffer); @@ -1097,7 +1098,7 @@ PrattTrie *insertPrattTrie(PrattTrie *current, HashSymbol *symbol) { return current; // skip internal tokens } size_t len = mbstowcs(NULL, symbol->name, 0) + 1; - PrattWVec *chars = newPrattWVec(len); + WCharVec *chars = newWCharVec(len); int save = PROTECT(chars); mbstowcs(chars->entries, symbol->name, len); PrattTrie *this = insertTrie(current, symbol, chars->entries); @@ -1122,7 +1123,7 @@ static PrattBuffer *prattBufferFromString(char *string) { if (len == (size_t)-1) { return NULL; } - PrattWVec *data = newPrattWVec(len + 1); + WCharVec *data = newWCharVec(len + 1); int save = PROTECT(data); mbstowcs(data->entries, string, len + 1); PrattBuffer *res = newPrattBuffer(data); @@ -1140,7 +1141,7 @@ static PrattBuffer *prattBufferFromString(char *string) { * @return A pointer to the newly created PrattBuffer. */ static PrattBuffer *prattBufferFromFileName(char *path) { - PrattWVec *content = readFile(path); + WCharVec *content = readFile(path); int save = PROTECT(content); PrattBuffer *res = newPrattBuffer(content); UNPROTECT(save); @@ -1280,7 +1281,7 @@ static PrattBufList *prattBufListFromMbString(char *string, char *origin, PrattBufList *next) { PrattBuffer *buffer = prattBufferFromString(string); if (buffer == NULL) { - can_happen("invalid encoding in %s", origin); + can_happen(NULLPI, "invalid encoding in %s", origin); buffer = prattBufferFromString(""); } int save = PROTECT(buffer); diff --git a/src/pratt_scanner.h b/src/pratt_scanner.h index f91de385..8331723f 100644 --- a/src/pratt_scanner.h +++ b/src/pratt_scanner.h @@ -72,6 +72,7 @@ HashSymbol *TOK_COLON(void); HashSymbol *TOK_COMMA(void); HashSymbol *TOK_ELSE(void); HashSymbol *TOK_EOF(void); +HashSymbol *TOK_EQ(void); HashSymbol *TOK_ERROR(void); HashSymbol *TOK_EXPORT(void); HashSymbol *TOK_FN(void); @@ -86,8 +87,8 @@ HashSymbol *TOK_LCURLY(void); HashSymbol *TOK_LEFT(void); HashSymbol *TOK_LET(void); HashSymbol *TOK_LINK(void); +HashSymbol *TOK_LAZY(void); HashSymbol *TOK_LSQUARE(void); -HashSymbol *TOK_MACRO(void); HashSymbol *TOK_NAMESPACE(void); HashSymbol *TOK_NONE(void); HashSymbol *TOK_NUMBER(void); diff --git a/src/preamble.fn b/src/preamble.fn index 5480c935..3cd1a7af 100644 --- a/src/preamble.fn +++ b/src/preamble.fn @@ -25,7 +25,7 @@ namespace __builtins__ -operator "_then_" right 2 amb; +lazy operator "_then_" right 2 amb; operator "_==_" left 5 EQUALTO; operator "_!=_" left 5 NOTEQUALTO; operator "_≠_" left 5 NOTEQUALTO; @@ -37,19 +37,19 @@ operator "_<=>_" none 5 COMPARISON; operator "_+_" left 10 ADDITION; operator "_-_" left 10 SUBTRACTION; operator "-_" left 11 NEGATION; -macro NUMERICIDENTITY(x) { x + 0 } +fn NUMERICIDENTITY(x) { x + 0 } operator "+_" left 11 NUMERICIDENTITY; operator "_*_" left 11 MULTIPLICATION; operator "_/_" left 11 DIVISION; operator "_%_" left 11 MODULUS; operator "_**_" left 12 EXPONENTIAL; -operator "here_" 13 callcc; +lazy operator "here_" 13 callcc; typedef cmp { lt | eq | gt } typedef bool { false | true } typedef list(#t) { nil | cons(#t, list(#t)) } alias string = list(char); -typedef maybe(#t) { nothing | some(#t) } +typedef maybe(#t) { nothing | just(#t) } typedef try(#f, #s) { failure(#f) | success(#s) } typedef basic_type { basic_null | basic_number(number) | basic_string(string) | basic_char(char) } typedef io_mode { io_read | io_write | io_append } @@ -83,13 +83,13 @@ fn NOT { } operator "not_" 4 NOT; -// macros aren't really macros, they're just lazy functions but that gets -// us most of the same behaviour. -macro AND(a, b) { if (a) { b } else { false } } -operator "_and_" left 3 AND; +// lazy functions thunk their arguments, which gets us short-circuit +// evaluation for boolean operators. +lazy fn AND(a, b) { if (a) { b } else { false } } +lazy operator "_and_" left 3 AND; -macro OR(a, b) { if (a) { true } else { b } } -operator "_or_" left 3 OR; +lazy fn OR(a, b) { if (a) { true } else { b } } +lazy operator "_or_" left 3 OR; fn XOR { (true, true) { false } @@ -99,14 +99,14 @@ fn XOR { } operator "_xor_" left 3 XOR; -macro NAND(a, b) { not (a and b) } -operator "_nand_" left 3 NAND; +lazy fn NAND(a, b) { not (a and b) } +lazy operator "_nand_" left 3 NAND; -macro NOR(a, b) { not (a or b) } -operator "_nor_" left 3 NOR; +lazy fn NOR(a, b) { not (a or b) } +lazy operator "_nor_" left 3 NOR; -macro XNOR(a, b) { not (a xor b) } -operator "_xnor_" left 3 XNOR; +lazy fn XNOR(a, b) { not (a xor b) } +lazy operator "_xnor_" left 3 XNOR; operator "_@_" right 10 cons; @@ -136,6 +136,18 @@ fn factorial (n) { operator "_!" 13 factorial; +fn gcd { + (0, b) { b } + (a, 0) { a } + (a, b) { + if (a > b) { + gcd(a - b, b) + } else { + gcd(a, b - a) + } + } +} + fn __error__(line, file, message) { puts("error: "); puts(message); @@ -149,8 +161,8 @@ fn __error__(line, file, message) { operator "_of_" right 13 fn (f, g, x) { f(g(x)) }; -operator "&_" 14 THUNK; -macro THUNK(x) { fn () {x} } +lazy operator "&_" 14 THUNK; +lazy fn THUNK(x) { fn () {x} } operator "*_" 14 FORCE; fn FORCE(thunk) { thunk() } diff --git a/src/primitives.yaml b/src/primitives.yaml index 990d94aa..c63d3f29 100644 --- a/src/primitives.yaml +++ b/src/primitives.yaml @@ -62,10 +62,10 @@ byte: file_id: data: - cname: "struct AgnosticFileId *" - printFn: printAgnosticFileId - compareFn: cmpAgnosticFileId - markFn: markAgnosticFileId + cname: "struct FileId *" + printFn: printFileId + eqFn: eqFileId + markFn: markFileId valued: true opaque: @@ -110,7 +110,7 @@ BigInt: cname: "struct BigInt *" printFn: "printBigInt" markFn: "markBigInt" - compareFn: "cmpBigInt" + cmpFn: "cmpBigInt" valued: true MaybeBigInt: @@ -118,7 +118,7 @@ MaybeBigInt: cname: "struct MaybeBigInt *" printFn: "printMaybeBigInt" markFn: "markMaybeBigInt" - compareFn: "cmpMaybeBigInt" + cmpFn: "cmpMaybeBigInt" valued: true string: @@ -163,3 +163,14 @@ size: printf: "%zu" valued: true +device: + data: + cname: dev_t + printf: "%lu" + valued: true + +inode: + data: + cname: ino_t + printf: "%lu" + valued: true diff --git a/src/print_compiler.c b/src/print_compiler.c index c83c4900..26bfdea1 100644 --- a/src/print_compiler.c +++ b/src/print_compiler.c @@ -20,22 +20,22 @@ * computes a print function that will print the given type */ -#include #include "print_compiler.h" -#include "print_generator.h" #include "cekf.h" #include "common.h" #include "lambda.h" #include "lambda_helper.h" #include "lambda_pp.h" +#include "print_generator.h" #include "symbol.h" #include "symbols.h" #include "tc_analyze.h" +#include #ifdef DEBUG_PRINT_COMPILER -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif static LamExp *compilePrinterForFunction(ParserInfo I, TcFunction *function); @@ -44,8 +44,10 @@ static LamExp *compilePrinterForThunk(ParserInfo I, TcThunk *thunk); static LamExp *compilePrinterForVar(ParserInfo I, TcVar *var, TcEnv *env); static LamExp *compilePrinterForInt(ParserInfo I); static LamExp *compilePrinterForChar(ParserInfo I); -static LamExp *compilePrinterForTypeSig(ParserInfo I, TcTypeSig *typeSig, TcEnv *env); -static LamExp *compilePrinterForTuple(ParserInfo I, TcTypeArray *tuple, TcEnv *env); +static LamExp *compilePrinterForTypeSig(ParserInfo I, TcTypeSig *typeSig, + TcEnv *env); +static LamExp *compilePrinterForTuple(ParserInfo I, TcTypeArray *tuple, + TcEnv *env); static LamExp *compilePrinter(ParserInfo I, TcType *type, TcEnv *env); static LamExp *makePutcExp(ParserInfo I, char c) { @@ -55,9 +57,7 @@ static LamExp *makePutcExp(ParserInfo I, char c) { PROTECT(putcArgs); LamExp *putc = newLamExp_Var(I, newSymbol("putc")); PROTECT(putc); - LamApply *applyPutc = newLamApply(I, putc, putcArgs); - PROTECT(applyPutc); - LamExp *putcExp = newLamExp_Apply(I, applyPutc); + LamExp *putcExp = makeLamExp_Apply(I, putc, putcArgs); UNPROTECT(save); return putcExp; } @@ -82,21 +82,17 @@ LamExp *compilePrinterForType(ParserInfo I, TcType *type, TcEnv *env) { // (printer x) (putc '\n') x) LamArgs *args = newLamArgs(I, var, NULL); PROTECT(args); - LamApply *apply = newLamApply(I, printer, args); - PROTECT(apply); - LamExp *applyExp = newLamExp_Apply(I, apply); + LamExp *applyExp = makeLamExp_Apply(I, printer, args); PROTECT(applyExp); seq = newLamSequence(I, applyExp, seq); PROTECT(seq); // (lambda (x) (begin (printer x) (putc '\n') x) - LamVarList *fargs = newLamVarList(I, name, NULL); + SymbolList *fargs = newSymbolList(I, name, NULL); PROTECT(fargs); LamExp *body = newLamExp_Sequence(I, seq); PROTECT(body); - LamLam *lambda = newLamLam(I, fargs, body); - PROTECT(lambda); - LamExp *res = newLamExp_Lam(I, lambda); + LamExp *res = makeLamExp_Lam(I, fargs, body); UNPROTECT(save); return res; } @@ -109,36 +105,36 @@ static LamExp *compilePrinter(ParserInfo I, TcType *type, TcEnv *env) { ENTER(compilePrinter); LamExp *res = NULL; switch (type->type) { - case TCTYPE_TYPE_FUNCTION: - res = compilePrinterForFunction(I, type->val.function); - break; - case TCTYPE_TYPE_PAIR: - res = compilePrinterForPair(I, type->val.pair); - break; - case TCTYPE_TYPE_THUNK: - res = compilePrinterForThunk(I, type->val.thunk); - break; - case TCTYPE_TYPE_VAR: - res = compilePrinterForVar(I, type->val.var, env); - break; - case TCTYPE_TYPE_SMALLINTEGER: - case TCTYPE_TYPE_BIGINTEGER: - res = compilePrinterForInt(I); - break; - case TCTYPE_TYPE_CHARACTER: - res = compilePrinterForChar(I); - break; - case TCTYPE_TYPE_OPAQUE: - res = compilePrinterForOpaque(I); - break; - case TCTYPE_TYPE_TYPESIG: - res = compilePrinterForTypeSig(I, type->val.typeSig, env); - break; - case TCTYPE_TYPE_TUPLE: - res = compilePrinterForTuple(I, type->val.tuple, env); - break; - default: - cant_happen("unrecognised TcType %s", tcTypeTypeName(type->type)); + case TCTYPE_TYPE_FUNCTION: + res = compilePrinterForFunction(I, type->val.function); + break; + case TCTYPE_TYPE_PAIR: + res = compilePrinterForPair(I, type->val.pair); + break; + case TCTYPE_TYPE_THUNK: + res = compilePrinterForThunk(I, type->val.thunk); + break; + case TCTYPE_TYPE_VAR: + res = compilePrinterForVar(I, type->val.var, env); + break; + case TCTYPE_TYPE_SMALLINTEGER: + case TCTYPE_TYPE_BIGINTEGER: + res = compilePrinterForInt(I); + break; + case TCTYPE_TYPE_CHARACTER: + res = compilePrinterForChar(I); + break; + case TCTYPE_TYPE_OPAQUE: + res = compilePrinterForOpaque(I); + break; + case TCTYPE_TYPE_TYPESIG: + res = compilePrinterForTypeSig(I, type->val.typeSig, env); + break; + case TCTYPE_TYPE_TUPLE: + res = compilePrinterForTuple(I, type->val.tuple, env); + break; + default: + cant_happen("unrecognised TcType %s", tcTypeTypeName(type->type)); } LEAVE(compilePrinter); return res; @@ -149,11 +145,13 @@ static LamExp *compilePrinterForFunction(ParserInfo I, TcFunction *function return makeVarExpr(I, "print$fn"); } -static LamExp *compilePrinterForPair(ParserInfo I __attribute__((unused)), TcPair *pair __attribute__((unused))) { +static LamExp *compilePrinterForPair(ParserInfo I __attribute__((unused)), + TcPair *pair __attribute__((unused))) { cant_happen("compilePrinterForPair not implemented yet"); } -static LamExp *compilePrinterForThunk(ParserInfo I, TcThunk *thunk __attribute__((unused))) { +static LamExp *compilePrinterForThunk(ParserInfo I, + TcThunk *thunk __attribute__((unused))) { // Thunks are functions, so use the function printer return makeVarExpr(I, "print$fn"); } @@ -165,16 +163,12 @@ static LamExp *compilePrinterForVar(ParserInfo I, TcVar *var, TcEnv *env) { return compilePrinter(I, var->instance, env); } -static LamExp *compilePrinterForInt(ParserInfo I) { - return makePrintInt(I); -} +static LamExp *compilePrinterForInt(ParserInfo I) { return makePrintInt(I); } -static LamExp *compilePrinterForChar(ParserInfo I) { - return makePrintChar(I); -} +static LamExp *compilePrinterForChar(ParserInfo I) { return makePrintChar(I); } static LamArgs *compilePrinterForTypeSigArgs(ParserInfo I, TcTypeSigArgs *args, - TcEnv *env) { + TcEnv *env) { ENTER(compilePrinterForTypeSigArgs); if (args == NULL) { LEAVE(compilePrinterForTypeSigArgs); @@ -190,7 +184,8 @@ static LamArgs *compilePrinterForTypeSigArgs(ParserInfo I, TcTypeSigArgs *args, return res; } -static LamArgs *compilePrinterForTupleArgs(ParserInfo I, TcTypeArray *tuple, TcEnv *env) { +static LamArgs *compilePrinterForTupleArgs(ParserInfo I, TcTypeArray *tuple, + TcEnv *env) { LamArgs *res = NULL; int save = PROTECT(res); for (int i = tuple->size; i > 0; i--) { @@ -227,11 +222,12 @@ static TcEnv *getNsEnv(int index, TcEnv *env) { return res->val.env; } -static LamExp *compilePrinterForTypeSig(ParserInfo I, TcTypeSig *typeSig, TcEnv *env) { +static LamExp *compilePrinterForTypeSig(ParserInfo I, TcTypeSig *typeSig, + TcEnv *env) { IFDEBUG(printTcTypeSig(typeSig, 0)); if (typeSig->name == listSymbol()) { - if (typeSig->args - && typeSig->args->type->type == TCTYPE_TYPE_CHARACTER) { + if (typeSig->args && + typeSig->args->type->type == TCTYPE_TYPE_CHARACTER) { return compilePrinterForString(I); } } @@ -255,14 +251,13 @@ static LamExp *compilePrinterForTypeSig(ParserInfo I, TcTypeSig *typeSig, TcEnv UNPROTECT(save); return exp; } - LamApply *apply = newLamApply(I, exp, args); - PROTECT(apply); - LamExp *res = newLamExp_Apply(I, apply); + LamExp *res = makeLamExp_Apply(I, exp, args); UNPROTECT(save); return res; } -static LamExp *compilePrinterForTuple(ParserInfo I, TcTypeArray *tuple, TcEnv *env) { +static LamExp *compilePrinterForTuple(ParserInfo I, TcTypeArray *tuple, + TcEnv *env) { ENTER(compilePrinterForTuple); if (tuple->size < 5) { char buf[64]; @@ -275,9 +270,7 @@ static LamExp *compilePrinterForTuple(ParserInfo I, TcTypeArray *tuple, TcEnv *e int save = PROTECT(exp); LamArgs *args = compilePrinterForTupleArgs(I, tuple, env); PROTECT(args); - LamApply *apply = newLamApply(I, exp, args); - PROTECT(apply); - LamExp *res = newLamExp_Apply(I, apply); + LamExp *res = makeLamExp_Apply(I, exp, args); UNPROTECT(save); IFDEBUG(ppLamExp(res)); LEAVE(compilePrinterForTuple); diff --git a/src/print_generator.c b/src/print_generator.c index 25da2487..b454abe2 100644 --- a/src/print_generator.c +++ b/src/print_generator.c @@ -27,13 +27,12 @@ * @details How print functions work: * Print functions are generated for all user defined types, unless the * user has explicityly defined a print function for the type. - * If the type has no type variables, then the generated print function simply - * takes the single value as argument. If the type has type variables however, - * then at the time of generating the print function it cannot know how to print - * those argument types and so it takes extra arguments, one per type variable, - * that are themselves print functions for the corresponding type variables, - * followed by the value to print. - * For example given + * If the type has no type variables, then the generated print function + * simply takes the single value as argument. If the type has type variables + * however, then at the time of generating the print function it cannot know how + * to print those argument types and so it takes extra arguments, one per type + * variable, that are themselves print functions for the corresponding type + * variables, followed by the value to print. For example given * ``` * typedef list(#t) { null | pair(#t, list(#t)) } * ``` @@ -54,13 +53,13 @@ * ``` * This is nice because all generated print functions have a consistent * structure and can easily be composed together. - * + * * The print compiler in `src/print_compiler.c` is responsible for * generating the actual applications of these print functions when the - * types are known. It runs as part of the type-checking phase of the compiler. + * types are known. It runs as part of the type-checking phase of the + * compiler. */ -#include #include "print_generator.h" #include "cekf.h" #include "common.h" @@ -68,29 +67,28 @@ #include "lambda_helper.h" #include "symbol.h" #include "symbols.h" +#include #ifdef DEBUG_PRINT_GENERATOR -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif -static LamBindings *makePrintTypeLetrec(ParserInfo I, - LamTypeDef *typeDef, - LamContext *env, - LamBindings *next); +static LamBindings *makePrintTypeLetrec(ParserInfo I, LamTypeDef *typeDef, + LamContext *env, LamBindings *next); /** * @brief Creates print functions for all type definitions in the list. * @param typeDefs The list of type definitions to create print functions for. * @param next The current set of letrec bindings. * @param env The current lambda context. - * @param inPreamble Whether the print functions are being created in the preamble. + * @param inPreamble Whether the print functions are being created in the + * preamble. * @return The updated set of letrec bindings with the new print functions. */ -LamBindings *makePrintFunctions(LamTypeDefList *typeDefs, - LamBindings *next, - LamContext *env) { +LamBindings *makePrintFunctions(LamTypeDefList *typeDefs, LamBindings *next, + LamContext *env) { ENTER(makePrintFunctions); if (typeDefs == NULL) { LEAVE(makePrintFunctions); @@ -99,7 +97,8 @@ LamBindings *makePrintFunctions(LamTypeDefList *typeDefs, next = makePrintFunctions(typeDefs->next, next, env); int save = PROTECT(next); - next = makePrintTypeLetrec(CPI(typeDefs->typeDef), typeDefs->typeDef, env, next); + next = makePrintTypeLetrec(CPI(typeDefs->typeDef), typeDefs->typeDef, env, + next); UNPROTECT(save); LEAVE(makePrintFunctions); @@ -108,10 +107,10 @@ LamBindings *makePrintFunctions(LamTypeDefList *typeDefs, /** * @brief Constructs a name from a prefix and a base name. - * + * * @param prefix The prefix to prepend to the base name. * @param name The base name to modify. - * @return A new symbol containing the combined name. + * @return A new symbol containing the combined name. */ HashSymbol *makePrintName(char *prefix, char *name) { HashSymbol *res = NULL; @@ -151,32 +150,34 @@ static LamExp *thingName(ParserInfo I) { } /** - * Generates the last argument to the print function, which is the "thing" to be printed. + * Generates the last argument to the print function, which is the "thing" to be + * printed. * @param I Parser information. * @return A new LamVarList representing the last argument. */ -static LamVarList *makeLastArg(ParserInfo I) { +static SymbolList *makeLastArg(ParserInfo I) { HashSymbol *name = printArgSymbol(); - return newLamVarList(I, name, NULL); + return newSymbolList(I, name, NULL); } /** * @brief Creates the formal argument list for a print function. - * - * @details Each print function takes one argument for each type variable in the type signature, - * (another print function) followed by the thing being printed. + * + * @details Each print function takes one argument for each type variable in the + * type signature, (another print function) followed by the thing being printed. * * @param I Parser information. * @param args The type signature arguments. - * @return A new LamVarList representing the arguments. + * @return A new LamVarList representing the arguments. */ -static LamVarList *makePrintTypeFunctionArgs(ParserInfo I, LamTypeSigArgs *args) { +static SymbolList *makePrintTypeFunctionArgs(ParserInfo I, + LamTypeSigArgs *args) { if (args == NULL) return makeLastArg(I); - LamVarList *next = makePrintTypeFunctionArgs(I, args->next); + SymbolList *next = makePrintTypeFunctionArgs(I, args->next); int save = PROTECT(next); HashSymbol *name = makePrintName("print", args->name->name); - LamVarList *res = newLamVarList(I, name, next); + SymbolList *res = newSymbolList(I, name, next); UNPROTECT(save); return res; } @@ -184,27 +185,24 @@ static LamVarList *makePrintTypeFunctionArgs(ParserInfo I, LamTypeSigArgs *args) /** * @brief Returns a cons of a lambda expression containing the character, * and the growing cons list. - * @details The list being constructed is not a simple lambda list, it is a sequence - * of vector constructors representing pairs of a character expression and - * the tail of the list. Note that because the plain lambda code is not yet - * typechecked, the cons structure includes the type constructor symbol "cons". + * @details The list being constructed is not a simple lambda list, it is a + * sequence of vector constructors representing pairs of a character expression + * and the tail of the list. Note that because the plain lambda code is not yet + * typechecked, the cons structure includes the type constructor symbol + * "cons". * @param I Parser information. * @param c The character to add to the cons list. * @param tail The tail of the cons list. * @return A new LamExp representing the cons list. */ static LamExp *makeCharList(ParserInfo I, char c, LamExp *tail) { - LamExp *character = - newLamExp_Character(I, c); + LamExp *character = newLamExp_Character(I, c); int save = PROTECT(character); LamArgs *args = newLamArgs(I, tail, NULL); PROTECT(args); args = newLamArgs(I, character, args); PROTECT(args); - LamConstruct *cons = newLamConstruct(I, consSymbol(), 1, args); - PROTECT(cons); - LamExp *res = - newLamExp_Construct(I, cons); + LamExp *res = makeLamExp_Construct(I, consSymbol(), 1, args); UNPROTECT(save); return res; } @@ -217,11 +215,7 @@ static LamExp *makeCharList(ParserInfo I, char c, LamExp *tail) { */ LamExp *stringToLamArgs(ParserInfo I, char *string) { if (*string == 0) { - LamConstruct *nil = newLamConstruct(I, nilSymbol(), 0, NULL); - int save = PROTECT(nil); - LamExp *res = newLamExp_Construct(I, nil); - UNPROTECT(save); - return res; + return makeLamExp_Construct(I, nilSymbol(), 0, NULL); } LamExp *next = stringToLamArgs(I, string + 1); int save = PROTECT(next); @@ -231,7 +225,8 @@ LamExp *stringToLamArgs(ParserInfo I, char *string) { } /** - * @brief takes a cons string and return a puts expression that will print that string. + * @brief takes a cons string and return a puts expression that will print that + * string. * @param I Parser information. * @param string The string to print. * @return A new LamExp representing the puts expression. @@ -241,9 +236,7 @@ static LamExp *putsExp(ParserInfo I, LamExp *string) { int save = PROTECT(puts); LamArgs *args = newLamArgs(I, string, NULL); PROTECT(args); - LamApply *apply = newLamApply(I, puts, args); - PROTECT(apply); - LamExp *res = newLamExp_Apply(I, apply); + LamExp *res = makeLamExp_Apply(I, puts, args); UNPROTECT(save); return res; } @@ -269,7 +262,8 @@ static LamExp *makePutsString(ParserInfo I, char *str) { * @param constructor The type constructor to print. * @return A new LamExp representing the puts expression. */ -static LamExp *makePutsConstructorName(ParserInfo I, LamTypeConstructor *constructor) { +static LamExp *makePutsConstructorName(ParserInfo I, + LamTypeConstructor *constructor) { LamExp *string = stringToLamArgs(I, constructor->name->name); int save = PROTECT(string); LamExp *puts = putsExp(I, string); @@ -284,14 +278,14 @@ static LamExp *makePutsConstructorName(ParserInfo I, LamTypeConstructor *constru * @param info The type constructor information. * @return A new LamExp representing the accessor expression. */ -static LamExp *makeIndexedDeconstruct(ParserInfo I, int index, LamTypeConstructorInfo *info) { +static LamExp *makeIndexedDeconstruct(ParserInfo I, int index, + LamTypeConstructorInfo *info) { LamExp *printArg = thingName(I); int save = PROTECT(printArg); LamDeconstruct *dec = newLamDeconstruct(I, info->type->name, info->nsId, index, printArg); PROTECT(dec); - LamExp *res = - newLamExp_Deconstruct(I, dec); + LamExp *res = newLamExp_Deconstruct(I, dec); UNPROTECT(save); return res; } @@ -313,12 +307,11 @@ LamExp *makeVarExpr(ParserInfo I, char *name) { * @param I Parser information. * @return A new LamExp representing the function name. */ -LamExp *makePrintInt(ParserInfo I) { - return makeVarExpr(I, "print$int"); -} +LamExp *makePrintInt(ParserInfo I) { return makeVarExpr(I, "print$int"); } /** - * @brief Returns the name of the character printer function as a lambda variable. + * @brief Returns the name of the character printer function as a lambda + * variable. * @param I Parser information. * @return A new LamExp representing the function name. */ @@ -327,9 +320,8 @@ LamExp *makePrintChar(ParserInfo I) { } /** - * @brief Creates a formal name for a printer function argument to another print function. - * i.e. - * name => printname + * @brief Creates a formal name for a printer function argument to another print + * function. i.e. name => printname * @param I Parser information. * @param var The variable to create the name for. * @return A new LamExp representing the printer function argument name. @@ -343,7 +335,8 @@ static LamExp *makeFarg(ParserInfo I, HashSymbol *var) { static LamExp *makeAarg(ParserInfo I, LamTypeConstructorType *arg); /** - * @brief Creates the actual arguments for an internal print function application. + * @brief Creates the actual arguments for an internal print function + * application. * @param I Parser information. * @param args The type constructor arguments to transform. * @return A new LamArgs representing the actual arguments. @@ -367,12 +360,12 @@ static LamArgs *makeAargs(ParserInfo I, LamTypeConstructorArgs *args) { */ static bool functionIsList(LamLookUpOrSymbol *los) { switch (los->type) { - case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: - return los->val.symbol == listSymbol(); - case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: - return false; - default: - cant_happen("unrecognized %s", lamLookUpOrSymbolTypeName(los->type)); + case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: + return los->val.symbol == listSymbol(); + case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: + return false; + default: + cant_happen("unrecognized %s", lamLookUpOrSymbolTypeName(los->type)); } } @@ -383,26 +376,28 @@ static bool functionIsList(LamLookUpOrSymbol *los) { */ static char *getUnderlyingFunctionName(LamLookUpOrSymbol *los) { switch (los->type) { - case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: - return los->val.symbol->name; - case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: - return los->val.lookUp->symbol->name; - default: - cant_happen("unrecognized %s", lamLookUpOrSymbolTypeName(los->type)); + case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: + return los->val.symbol->name; + case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: + return los->val.lookUp->symbol->name; + default: + cant_happen("unrecognized %s", lamLookUpOrSymbolTypeName(los->type)); } } /** * @brief Wraps a print function in a lookUp expression if necessary. - * @details The argument toPrint is the lookUp or symbol of the thing being printed. - * The argument printer is the print function. - * If the toPrint is just a symbol, then the printer is assumed to be in the current scope and returned unchanged. - * If the toPrint is a lookUp, then the printer is assumed to be in that scope and is wrapped in the same lookUp expression. + * @details The argument toPrint is the lookUp or symbol of the thing being + * printed. The argument printer is the print function. If the toPrint is just a + * symbol, then the printer is assumed to be in the current scope and returned + * unchanged. If the toPrint is a lookUp, then the printer is assumed to be in + * that scope and is wrapped in the same lookUp expression. * @param I Parser information. * @param printer The print function to wrap. * @param los The lookUp or symbol of the thing being printed. */ -static LamExp *lookUpPrintFunction(ParserInfo I, LamExp *printer, LamLookUpOrSymbol *toPrint) { +static LamExp *lookUpPrintFunction(ParserInfo I, LamExp *printer, + LamLookUpOrSymbol *toPrint) { if (toPrint->type == LAMLOOKUPORSYMBOL_TYPE_LOOKUP) { LamLookUpSymbol *ls = toPrint->val.lookUp; LamLookUp *llu = newLamLookUp(I, ls->nsId, ls->nsSymbol, printer); @@ -421,14 +416,14 @@ static LamExp *lookUpPrintFunction(ParserInfo I, LamExp *printer, LamLookUpOrSym */ static LamExp *makePrintTypeFunction(ParserInfo I, LamTypeFunction *function) { if (functionIsList(function->name)) { - if (function->args - && function->args->arg->type == - LAMTYPECONSTRUCTORTYPE_TYPE_CHARACTER) { + if (function->args && function->args->arg->type == + LAMTYPECONSTRUCTORTYPE_TYPE_CHARACTER) { HashSymbol *name = newSymbol("print$string"); return newLamExp_Var(I, name); } } - HashSymbol *name = makePrintName("print$", getUnderlyingFunctionName(function->name)); + HashSymbol *name = + makePrintName("print$", getUnderlyingFunctionName(function->name)); LamExp *exp = newLamExp_Var(I, name); int save = PROTECT(exp); exp = lookUpPrintFunction(I, exp, function->name); @@ -440,9 +435,7 @@ static LamExp *makePrintTypeFunction(ParserInfo I, LamTypeFunction *function) { UNPROTECT(save); return exp; } - LamApply *apply = newLamApply(I, exp, args); - PROTECT(apply); - LamExp *res = newLamExp_Apply(I, apply); + LamExp *res = makeLamExp_Apply(I, exp, args); UNPROTECT(save); return res; } @@ -453,34 +446,31 @@ static LamExp *makePrintTypeFunction(ParserInfo I, LamTypeFunction *function) { */ static LamExp *makePrintTuple(ParserInfo I, LamTypeConstructorArgs *tuple) { int size = countLamTypeConstructorArgs(tuple); - HashSymbol *name = NULL; - if (size <= 4) { - char buf[64]; - sprintf(buf, "%d", size); - name = makePrintName("print$tuple_", buf); - } else { - name = newSymbol("print$"); - LamExp *exp = newLamExp_Var(I, name); - return exp; + if (size > 4) { + return newLamExp_Var(I, newSymbol("print$")); } + char buf[64]; + sprintf(buf, "%d", size); + HashSymbol *name = makePrintName("print$tuple_", buf); LamExp *exp = newLamExp_Var(I, name); int save = PROTECT(exp); LamArgs *args = makeAargs(I, tuple); PROTECT(args); - LamApply *apply = newLamApply(I, exp, args); - PROTECT(apply); - LamExp *res = newLamExp_Apply(I, apply); + LamExp *res = makeLamExp_Apply(I, exp, args); UNPROTECT(save); return res; } /** - * @brief Creates the actual argument for a print function passed to another print function. - * @details This function generates the appropriate printer expression for a given type - * of type constructor argument (so without the final "thing" argument): + * @brief Creates the actual argument for a print function passed to another + * print function. + * @details This function generates the appropriate printer expression for a + * given type of type constructor argument (so without the final "thing" + * argument): * - integer: `print$int`. * - character: `print$character`. - * - type variable `var`: `printvar` where `printvar` is expected to be in scope. + * - type variable `var`: `printvar` where `printvar` is expected to be + * in scope. * - type function: `print$function(print$arg1, ...)` * - tuple: `print$tuple_(print$arg1, print$arg2, ...)` * @param I Parser information. @@ -490,30 +480,31 @@ static LamExp *makePrintTuple(ParserInfo I, LamTypeConstructorArgs *tuple) { static LamExp *makeAarg(ParserInfo I, LamTypeConstructorType *arg) { LamExp *printer = NULL; switch (arg->type) { - case LAMTYPECONSTRUCTORTYPE_TYPE_INTEGER: - printer = makePrintInt(I); - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_CHARACTER: - printer = makePrintChar(I); - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_VAR: - printer = makeFarg(I, arg->val.var); - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_FUNCTION: - printer = makePrintTypeFunction(I, arg->val.function); - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_TUPLE: - printer = makePrintTuple(I, arg->val.tuple); - break; - default: - cant_happen("unrecognised type %s in makeAarg", lamTypeConstructorTypeTypeName(arg->type)); + case LAMTYPECONSTRUCTORTYPE_TYPE_INTEGER: + printer = makePrintInt(I); + break; + case LAMTYPECONSTRUCTORTYPE_TYPE_CHARACTER: + printer = makePrintChar(I); + break; + case LAMTYPECONSTRUCTORTYPE_TYPE_VAR: + printer = makeFarg(I, arg->val.var); + break; + case LAMTYPECONSTRUCTORTYPE_TYPE_FUNCTION: + printer = makePrintTypeFunction(I, arg->val.function); + break; + case LAMTYPECONSTRUCTORTYPE_TYPE_TUPLE: + printer = makePrintTuple(I, arg->val.tuple); + break; + default: + cant_happen("unrecognised type %s in makeAarg", + lamTypeConstructorTypeTypeName(arg->type)); } return printer; } /** - * @brief Builds the application of a printer for the given componentType to the componentIndex-th - * component of the structure described by the constructorInfo + * @brief Builds the application of a printer for the given componentType to the + * componentIndex-th component of the structure described by the constructorInfo * @param I Parser information. * @param componentType The type of the component to print. * @param constructorInfo The constructor information to build the accessor. @@ -524,15 +515,14 @@ static LamExp *makeIndexedApplication(ParserInfo I, LamTypeConstructorType *componentType, LamTypeConstructorInfo *constructorInfo, int componentIndex) { - LamExp *accessor = makeIndexedDeconstruct(I, componentIndex, constructorInfo); + LamExp *accessor = + makeIndexedDeconstruct(I, componentIndex, constructorInfo); int save = PROTECT(accessor); LamExp *printer = makeAarg(I, componentType); PROTECT(printer); LamArgs *args = newLamArgs(I, accessor, NULL); PROTECT(args); - LamApply *apply = newLamApply(I, printer, args); - PROTECT(apply); - LamExp *res = newLamExp_Apply(I, apply); + LamExp *res = makeLamExp_Apply(I, printer, args); UNPROTECT(save); return res; } @@ -563,14 +553,14 @@ static HashSymbol *findNthTag(int index, LamTypeTags *tags) { * @param info The constructor information. * @return A new LamSequence representing the match parts. */ -static LamSequence *makeVectorMatchParts(ParserInfo I, - int index, +static LamSequence *makeVectorMatchParts(ParserInfo I, int index, LamTypeConstructorArgs *args, LamTypeConstructorInfo *info, LamSequence *tail) { if (args == NULL) return tail; - LamSequence *next = makeVectorMatchParts(I, index + 1, args->next, info, tail); + LamSequence *next = + makeVectorMatchParts(I, index + 1, args->next, info, tail); int save = PROTECT(next); LamExp *exp = makeIndexedApplication(I, args->arg, info, index + 1); PROTECT(exp); @@ -598,16 +588,16 @@ static LamSequence *makeVectorMatchParts(ParserInfo I, } /** - * @brief Builds the body of a match expression for a type constructor with arity greater than 0. - * @details This function creates the body of the match expression for a vector-based type, - * which includes printing the constructor name, opening the structure, printing - * each component, and closing the structure. + * @brief Builds the body of a match expression for a type constructor with + * arity greater than 0. + * @details This function creates the body of the match expression for a + * vector-based type, which includes printing the constructor name, opening the + * structure, printing each component, and closing the structure. * @param I Parser information. * @param info The type constructor information. * @return A new LamExp representing the match body. */ -static LamExp *makeVectorMatchBody(ParserInfo I, - LamTypeConstructorInfo *info) { +static LamExp *makeVectorMatchBody(ParserInfo I, LamTypeConstructorInfo *info) { LamTypeConstructor *constructor = info->type; LamExp *header = makePutsConstructorName(I, constructor); int save = PROTECT(header); @@ -630,10 +620,12 @@ static LamExp *makeVectorMatchBody(ParserInfo I, } /** - * @brief Builds the individual match cases for a type whose constructors create scalars. - * @details If none of the constructors have arity greater than 0, they can be represented as - * simple scalars, for example `typedef colours { red, green, blue }`. - * This function is called to recursively create the match cases for those scalar-based types. + * @brief Builds the individual match cases for a type whose constructors create + * scalars. + * @details If none of the constructors have arity greater than 0, they can be + * represented as simple scalars, for example `typedef colours { red, green, + * blue }`. This function is called to recursively create the match cases for + * those scalar-based types. * @param I Parser information. * @param constructors The list of type constructors for the type being matched. * @param env The current lambda context. @@ -649,11 +641,12 @@ static LamMatchList *makeScalarMatchList(ParserInfo I, LamTypeConstructorInfo *info = lookUpConstructorInLamContext(env, constructors->constructor->name); if (info == NULL) { - cant_happen - ("cannot find info for type constructor %s in makeScalarMatchList", - constructors->constructor->name->name); + cant_happen( + "cannot find info for type constructor %s in makeScalarMatchList", + constructors->constructor->name->name); } - LamIntList *matches = newLamIntList(I, info->index, info->type->name, info->nsId, NULL); + LamIntList *matches = + newLamIntList(I, info->index, info->type->name, info->nsId, NULL); PROTECT(matches); LamExp *body = makePutsConstructorName(I, constructors->constructor); PROTECT(body); @@ -663,10 +656,12 @@ static LamMatchList *makeScalarMatchList(ParserInfo I, } /** - * @brief Builds a match expression for a type whose constructors create only scalars. - * @details If none of the constructors have arity greater than 0, they can be represented as - * simple scalars, for example `typedef colours { red, green, blue }`. - * This function is called to create a match expression for those scalar-based types. + * @brief Builds a match expression for a type whose constructors create only + * scalars. + * @details If none of the constructors have arity greater than 0, they can be + * represented as simple scalars, for example `typedef colours { red, green, + * blue }`. This function is called to create a match expression for those + * scalar-based types. * @param I Parser information. * @param constructors The list of type constructors for the type being matched. * @param env The current lambda context. @@ -685,19 +680,20 @@ static LamMatch *makeScalarMatch(ParserInfo I, } /** - * @brief Builds the individual match cases for a type whose constructors create vectors. - * @details If any of the constructors have arity greater than 0, they all need to create - * vectors (so that the match does not need to distinguish between their structures). - * This function is called to recursively create the match cases for those - * vector-based types. + * @brief Builds the individual match cases for a type whose constructors create + * vectors. + * @details If any of the constructors have arity greater than 0, they all need + * to create vectors (so that the match does not need to distinguish between + * their structures). This function is called to recursively create the match + * cases for those vector-based types. * @param I Parser information. * @param constructors The list of type constructors for the type being matched. * @param env The current lambda context. * @return The match expression. */ static LamMatchList *makeVectorMatchList(ParserInfo I, - LamTypeConstructorList *constructors, - LamContext *env) { + LamTypeConstructorList *constructors, + LamContext *env) { if (constructors == NULL) return NULL; LamMatchList *next = makeVectorMatchList(I, constructors->next, env); @@ -705,11 +701,12 @@ static LamMatchList *makeVectorMatchList(ParserInfo I, LamTypeConstructorInfo *info = lookUpConstructorInLamContext(env, constructors->constructor->name); if (info == NULL) { - cant_happen - ("cannot find info for type constructor %s in makeVectorMatchList", - constructors->constructor->name->name); + cant_happen( + "cannot find info for type constructor %s in makeVectorMatchList", + constructors->constructor->name->name); } - LamIntList *matches = newLamIntList(I, info->index, info->type->name, info->nsId, NULL); + LamIntList *matches = + newLamIntList(I, info->index, info->type->name, info->nsId, NULL); PROTECT(matches); LamExp *body = NULL; if (info->arity > 0) { @@ -724,10 +721,12 @@ static LamMatchList *makeVectorMatchList(ParserInfo I, } /** - * @brief Builds a match expression for a type whose constructors create vectors. - * @details If any of the constructors have arity greater than 0, they all need to create - * vectors (so that the match does not need to distinguish between their structures). - * This function is called to create a match expression for those vector-based types. + * @brief Builds a match expression for a type whose constructors create + * vectors. + * @details If any of the constructors have arity greater than 0, they all need + * to create vectors (so that the match does not need to distinguish between + * their structures). This function is called to create a match expression for + * those vector-based types. * @param I Parser information. * @param constructors The list of type constructors for the type being matched. * @param env The current lambda context. @@ -760,9 +759,9 @@ static LamExp *makeFunctionBody(ParserInfo I, LamTypeConstructorInfo *info = lookUpConstructorInLamContext(env, constructors->constructor->name); if (info == NULL) { - cant_happen - ("cannot find info for type constructor %s in makeFunctionBody", - constructors->constructor->name->name); + cant_happen( + "cannot find info for type constructor %s in makeFunctionBody", + constructors->constructor->name->name); } LamMatch *match = NULL; if (info->needsVec) { @@ -792,8 +791,10 @@ static LamExp *makeFunctionBody(ParserInfo I, * @return True if the print function is already defined, false otherwise. */ static bool userDefined(HashSymbol *printName, LamBindings *bindings) { - if (bindings == NULL) return false; - if (bindings->var == printName) return true; + if (bindings == NULL) + return false; + if (bindings->var == printName) + return true; return userDefined(printName, bindings->next); } @@ -805,15 +806,13 @@ static bool userDefined(HashSymbol *printName, LamBindings *bindings) { * @param next The next letrec binding in the chain. * @return The new letrec binding for the print function. */ -static LamBindings *makePrintTypeLetrec(ParserInfo I, - LamTypeDef *typeDef, - LamContext *env, - LamBindings *next) { +static LamBindings *makePrintTypeLetrec(ParserInfo I, LamTypeDef *typeDef, + LamContext *env, LamBindings *next) { HashSymbol *name = makePrintName("print$", typeDef->type->name->name); if (userDefined(name, next)) { return next; } - LamVarList *args = makePrintTypeFunctionArgs(I, typeDef->type->args); + SymbolList *args = makePrintTypeFunctionArgs(I, typeDef->type->args); int save = PROTECT(args); LamExp *body = makeFunctionBody(I, typeDef->constructors, env); PROTECT(body); diff --git a/src/step.c b/src/step.c index 1a40c45c..d163a858 100644 --- a/src/step.c +++ b/src/step.c @@ -15,26 +15,26 @@ * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ -#include +#include +#include #include +#include #include #include #include #include #include -#include -#include +#include "arithmetic.h" +#include "builtin_io.h" +#include "builtins_debug.h" +#include "builtins_impl.h" +#include "cekf.h" #include "common.h" #include "debug.h" -#include "cekf.h" -#include "step.h" #include "hash.h" -#include "arithmetic.h" -#include "builtins_impl.h" -#include "builtins_debug.h" #include "memory.h" -#include "builtin_io.h" +#include "step.h" #ifdef UNIT_TESTS #include "tests/step.h" @@ -43,9 +43,9 @@ int dump_bytecode_flag = 0; #ifdef DEBUG_STEP -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif /** @@ -71,7 +71,7 @@ static inline void pushOverApplyFrame(int extra, Vec *vec) { } static inline void popOverApplyFrame(void) { - (void) popOverApplyStack(overApplyStack); + (void)popOverApplyStack(overApplyStack); } void markState() { @@ -85,15 +85,18 @@ static unsigned long apply_exact_calls = 0; static unsigned long apply_partial_creations = 0; // Count legacy over-attempts (still reported if any unreachable path triggers) static unsigned long apply_over_attempts __attribute__((unused)) = 0; -static unsigned long apply_staged_steps = 0; // number of staged extra arg applications +static unsigned long apply_staged_steps = + 0; // number of staged extra arg applications // Centralized arity error reporting for APPLY paths -static inline void arity_error(const char *kind, int expected, int got) __attribute__((unused)); -static inline void arity_error(const char *kind, int expected, int got) { +__attribute__((unused)) static inline void arity_error(const char *kind, + int expected, int got) { #ifdef SAFETY_CHECKS - cant_happen("arity error (%s): expected %d, got %d at %04lx", kind, expected, got, state.C); + cant_happen("arity error (%s): expected %d, got %d at %04lx", kind, + expected, got, state.C); #else - eprintf("arity error (%s): expected %d, got %d at %04lx\n", kind, expected, got, state.C); + eprintf("arity error (%s): expected %d, got %d at %04lx\n", kind, expected, + got, state.C); state.C = END_CONTROL; #endif } @@ -102,14 +105,19 @@ static inline void arity_error(const char *kind, int expected, int got) { #ifdef SAFETY_CHECKS static inline void assert_stack_has_args(int naargs) { Index available = totalSizeStack(state.S); - if (naargs < 0 || available < (Index) naargs) { - cant_happen("APPLY with insufficient arguments on stack: need %d, have %u", naargs, available); + if (naargs < 0 || available < (Index)naargs) { + cant_happen( + "APPLY with insufficient arguments on stack: need %d, have %u", + naargs, available); } } #endif -// --- Basic stack convenience wrappers (moved earlier so helpers can use them) --- -static inline void patch(Value v, int num) { patchVec(v.val.nameSpace, state.S, num); } +// --- Basic stack convenience wrappers (moved earlier so helpers can use them) +// --- +static inline void patch(Value v, int num) { + patchVec(v.val.nameSpace, state.S, num); +} static inline void poke(int offset, Value v) { pokeStack(state.S, offset, v); } static inline void push(Value v) { pushStackEntry(state.S, v); } static inline void extend(int i) { pushnStack(state.S, i, vVoid); } @@ -126,7 +134,8 @@ static inline void exactCallFromPclo(Clo *clo, int naargs) { // leaving space for the captured args below them moveStack(state.S, ncaptured, naargs); // copy captured args to base of the stack - copyValues(&state.S->entries[state.S->frame], clo->E->S->entries, ncaptured); + copyValues(&state.S->entries[state.S->frame], clo->E->S->entries, + ncaptured); // set stack pointer to the last arg state.S->offset = ncaptured + naargs; // step into body of closure @@ -143,7 +152,8 @@ static inline void exactCallFromClo(Clo *clo) { apply_exact_calls++; } -// Helper: create a new partial closure from an existing PCLO given additional args +// Helper: create a new partial closure from an existing PCLO given additional +// args static inline void makePartialFromPclo(Value *callable, Clo *clo, int naargs) { int ncaptured = clo->E->S->size; // create a new env which is a sibling of the partial closure's env. @@ -184,16 +194,18 @@ static inline void makePartialFromClo(Value *callable, Clo *clo, int naargs) { apply_partial_creations++; } - -static Env *builtInsToEnv(BuiltIns *b)__attribute__((unused)); +static Env *builtInsToEnv(BuiltIns *b) __attribute__((unused)); static Env *builtInsToEnv(BuiltIns *b) { Env *env = makeEnv(NULL); int save = PROTECT(env); for (Index i = 0; i < b->size; i++) { BuiltIn *builtIn = b->entries[i]; - DEBUG("adding builtin %s/%s at %p", builtIn->internalName->name, builtIn->externalName->name, builtIn->implementation); - BuiltInImplementation *implInternal = newBuiltInImplementation(builtIn->internalName, builtIn->implementation, builtIn->args->size); + DEBUG("adding builtin %s/%s at %p", builtIn->internalName->name, + builtIn->externalName->name, builtIn->implementation); + BuiltInImplementation *implInternal = newBuiltInImplementation( + builtIn->internalName, builtIn->implementation, + builtIn->args->size); PROTECT(implInternal); pushFrame(env->S, value_BuiltIn(implInternal)); } @@ -201,7 +213,8 @@ static Env *builtInsToEnv(BuiltIns *b) { return env; } -static void inject(ByteCodeArray B, LocationArray *L, BuiltIns *builtIns __attribute__((unused))) { +static void inject(ByteCodeArray B, LocationArray *L, + BuiltIns *builtIns __attribute__((unused))) { static bool first = true; state.C = 0; state.E = builtInsToEnv(builtIns); @@ -231,17 +244,13 @@ void run(ByteCodeArray B, LocationArray *L, BuiltIns *builtIns) { collectGarbage(); } -static inline int readCurrentByte(void) { - return readByte(&state.B, &state.C); -} +static inline int readCurrentByte(void) { return readByte(&state.B, &state.C); } static inline Character readCurrentCharacter(void) { return readCharacter(&state.B, &state.C); } -static inline int readCurrentWord(void) { - return readWord(&state.B, &state.C); -} +static inline int readCurrentWord(void) { return readWord(&state.B, &state.C); } static inline Integer readCurrentInt(void) { return readInteger(&state.B, &state.C); @@ -268,8 +277,8 @@ static inline int readCurrentOffsetAt(int i) { static bool truthy(Value v) { // FIXME this can't be right now! - return !((v.type == VALUE_TYPE_STDINT && v.val.stdint == 0) - || v.type == VALUE_TYPE_NONE); + return !((v.type == VALUE_TYPE_STDINT && v.val.stdint == 0) || + v.type == VALUE_TYPE_NONE); } static Cmp _cmp(Value left, Value right); @@ -294,12 +303,23 @@ static Cmp _vecCmp(Vec *left, Vec *right) { return CMP_EQ; } -#define _CMP_(left, right) ((left) < (right) ? CMP_LT : (left) == (right) ? CMP_EQ : CMP_GT) +#define _CMP_(left, right) \ + ((left) < (right) ? CMP_LT : (left) == (right) ? CMP_EQ : CMP_GT) static Cmp _cmp(Value left, Value right) { #ifdef SAFETY_CHECKS if (left.type != right.type) { switch (left.type) { + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_COMPLEX: + switch (right.type) { case VALUE_TYPE_BIGINT: case VALUE_TYPE_STDINT: case VALUE_TYPE_RATIONAL: @@ -309,81 +329,64 @@ static Cmp _cmp(Value left, Value right) { case VALUE_TYPE_IRRATIONAL_IMAG: case VALUE_TYPE_RATIONAL_IMAG: case VALUE_TYPE_COMPLEX: - switch (right.type) { - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - break; - default: - cant_happen("different types in _cmp %s vs %s", - valueTypeName(left.type), - valueTypeName(right.type)); - } break; default: cant_happen("different types in _cmp %s vs %s", valueTypeName(left.type), valueTypeName(right.type)); + } + break; + default: + cant_happen("different types in _cmp %s vs %s", + valueTypeName(left.type), valueTypeName(right.type)); } } #endif switch (left.type) { - case VALUE_TYPE_NONE: - return 0; - case VALUE_TYPE_BIGINT: - case VALUE_TYPE_STDINT: - case VALUE_TYPE_RATIONAL: - case VALUE_TYPE_IRRATIONAL: - case VALUE_TYPE_BIGINT_IMAG: - case VALUE_TYPE_STDINT_IMAG: - case VALUE_TYPE_RATIONAL_IMAG: - case VALUE_TYPE_IRRATIONAL_IMAG: - case VALUE_TYPE_COMPLEX: - return ncmp(left, right); - case VALUE_TYPE_CHARACTER: - return _CMP_(left.val.character, right.val.character); - case VALUE_TYPE_CLO: - case VALUE_TYPE_PCLO: - return _CMP_(left.val.clo->C, right.val.clo->C); - case VALUE_TYPE_KONT: - return _CMP_(left.val.kont->C, right.val.kont->C); - case VALUE_TYPE_VEC: - return _vecCmp(left.val.vec, right.val.vec); - default: - cant_happen("unexpected type for _cmp (%s)", valueTypeName(left.type)); + case VALUE_TYPE_NONE: + return 0; + case VALUE_TYPE_BIGINT: + case VALUE_TYPE_STDINT: + case VALUE_TYPE_RATIONAL: + case VALUE_TYPE_IRRATIONAL: + case VALUE_TYPE_BIGINT_IMAG: + case VALUE_TYPE_STDINT_IMAG: + case VALUE_TYPE_RATIONAL_IMAG: + case VALUE_TYPE_IRRATIONAL_IMAG: + case VALUE_TYPE_COMPLEX: + return ncmp(left, right); + case VALUE_TYPE_CHARACTER: + return _CMP_(left.val.character, right.val.character); + case VALUE_TYPE_CLO: + case VALUE_TYPE_PCLO: + return _CMP_(left.val.clo->C, right.val.clo->C); + case VALUE_TYPE_KONT: + return _CMP_(left.val.kont->C, right.val.kont->C); + case VALUE_TYPE_VEC: + return _vecCmp(left.val.vec, right.val.vec); + default: + cant_happen("unexpected type for _cmp (%s)", valueTypeName(left.type)); } } static Value vcmp(Value left, Value right) { switch (_cmp(left, right)) { - case CMP_LT: - return vLt; - case CMP_EQ: - return vEq; - case CMP_GT: - return vGt; - default: - cant_happen("unexpected value from _cmp"); + case CMP_LT: + return vLt; + case CMP_EQ: + return vEq; + case CMP_GT: + return vGt; + default: + cant_happen("unexpected value from _cmp"); } } -static bool _eq(Value left, Value right) { - return _cmp(left, right) == CMP_EQ; -} +static bool _eq(Value left, Value right) { return _cmp(left, right) == CMP_EQ; } -static bool _gt(Value left, Value right) { - return _cmp(left, right) == CMP_GT; -} +static bool _gt(Value left, Value right) { return _cmp(left, right) == CMP_GT; } -static bool _lt(Value left, Value right) { - return _cmp(left, right) == CMP_LT; -} +static bool _lt(Value left, Value right) { return _cmp(left, right) == CMP_LT; } static Value eq(Value left, Value right) { bool result = _eq(left, right); @@ -418,14 +421,17 @@ static Value le(Value left, Value right) { static Value vec(Value index, Value vector) { #ifdef SAFETY_CHECKS if (index.type != VALUE_TYPE_STDINT) - cant_happen("invalid index type for vec %d location %04lx", index.type, state.C); + cant_happen("invalid index type for vec %d location %04lx", index.type, + state.C); if (vector.type != VALUE_TYPE_VEC) - cant_happen("invalid vector type for vec %d location %04lx", vector.type, state.C); + cant_happen("invalid vector type for vec %d location %04lx", + vector.type, state.C); #endif 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); + 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); return vec->entries[i]; } @@ -470,102 +476,109 @@ static void applyProc(int naargs) { Value callable = pop(); int save = protectValue(callable); switch (callable.type) { - case VALUE_TYPE_PCLO:{ - Clo *clo = callable.val.clo; - int ncaptured __attribute__((unused)) = clo->E->S->size; - DEBUG("PCLO ncaptured = %d, naargs = %d, pending = %d", ncaptured, naargs, clo->pending); - if (clo->pending == naargs) { - exactCallFromPclo(clo, naargs); - } else if (naargs == 0) { - // args expected, no args passed, no-op - push(callable); - } else if (naargs < clo->pending) { - makePartialFromPclo(&callable, clo, naargs); - } else { - // Stage over-application: store extra args, perform exact call now, apply extras later. - int pending = clo->pending; - int extra = naargs - pending; + case VALUE_TYPE_PCLO: { + Clo *clo = callable.val.clo; + int ncaptured __attribute__((unused)) = clo->E->S->size; + DEBUG("PCLO ncaptured = %d, naargs = %d, pending = %d", ncaptured, + naargs, clo->pending); + if (clo->pending == naargs) { + exactCallFromPclo(clo, naargs); + } else if (naargs == 0) { + // args expected, no args passed, no-op + push(callable); + } else if (naargs < clo->pending) { + makePartialFromPclo(&callable, clo, naargs); + } else { + // Stage over-application: store extra args, perform exact call now, + // apply extras later. + int pending = clo->pending; + int extra = naargs - pending; #ifdef SAFETY_CHECKS - if (extra <= 0) cant_happen("PCLO staging invariant"); + if (extra <= 0) + cant_happen("PCLO staging invariant"); #endif - Vec *vec = newVec(extra); - int saveExtras = PROTECT(vec); - // pop a_n..a_{pending+1} storing so that entries[0] is first extra arg - for (int i = 0; i < extra; i++) { - Value v = pop(); - vec->entries[extra - 1 - i] = v; - } - pushOverApplyFrame(extra, vec); - UNPROTECT(saveExtras); - exactCallFromPclo(clo, pending); - // Do NOT apply extras now; resume after body completes. - } + Vec *vec = newVec(extra); + int saveExtras = PROTECT(vec); + // pop a_n..a_{pending+1} storing so that entries[0] is first extra + // arg + for (int i = 0; i < extra; i++) { + Value v = pop(); + vec->entries[extra - 1 - i] = v; } - break; - case VALUE_TYPE_CLO:{ - Clo *clo = callable.val.clo; - DEBUG("CLO pending = %d, naargs = %d", clo->pending, naargs); - if (clo->pending == naargs) { - exactCallFromClo(clo); - } else if (naargs == 0) { - push(callable); - } else if (naargs < clo->pending) { - makePartialFromClo(&callable, clo, naargs); - } else { - // Stage over-application for CLO - int pending = clo->pending; - int extra = naargs - pending; + pushOverApplyFrame(extra, vec); + UNPROTECT(saveExtras); + exactCallFromPclo(clo, pending); + // Do NOT apply extras now; resume after body completes. + } + } break; + case VALUE_TYPE_CLO: { + Clo *clo = callable.val.clo; + DEBUG("CLO pending = %d, naargs = %d", clo->pending, naargs); + if (clo->pending == naargs) { + exactCallFromClo(clo); + } else if (naargs == 0) { + push(callable); + } else if (naargs < clo->pending) { + makePartialFromClo(&callable, clo, naargs); + } else { + // Stage over-application for CLO + int pending = clo->pending; + int extra = naargs - pending; #ifdef SAFETY_CHECKS - if (extra <= 0) cant_happen("CLO staging invariant"); + if (extra <= 0) + cant_happen("CLO staging invariant"); #endif - Vec *vec = newVec(extra); - int saveExtras = PROTECT(vec); - for (int i = 0; i < extra; i++) { - Value v = pop(); - vec->entries[extra - 1 - i] = v; - } - pushOverApplyFrame(extra, vec); - UNPROTECT(saveExtras); - exactCallFromClo(clo); - } - } - break; - case VALUE_TYPE_KONT:{ - if (callable.val.kont == NULL) { - state.C = END_CONTROL; - } else { - Value result = pop(); - protectValue(result); - Kont *kont = callable.val.kont; - state.C = kont->C; - state.K = kont->K; - state.E = kont->E; - restoreKont(state.S, kont); - push(result); - } - } - break; - case VALUE_TYPE_BUILTIN:{ - BuiltInImplementation *impl = callable.val.builtIn; - if (naargs == impl->nArgs) { - BuiltInFunction fn = (BuiltInFunction) impl->implementation; - Vec *v = newVec(impl->nArgs); - int save = PROTECT(v); - copyValues(v->entries, &(state.S->entries[totalSizeStack(state.S) - impl->nArgs]), impl->nArgs); - Value res = fn(v); - protectValue(res); - state.S->offset -= impl->nArgs; - push(res); - UNPROTECT(save); - } else if (naargs == 0) { - push(callable); - } else { - cant_happen("curried built-ins not supported yet (expected %d got %d)", impl->nArgs, naargs); - } + Vec *vec = newVec(extra); + int saveExtras = PROTECT(vec); + for (int i = 0; i < extra; i++) { + Value v = pop(); + vec->entries[extra - 1 - i] = v; } - break; - default: - cant_happen("unexpected type %s in APPLY", valueTypeName(callable.type)); + pushOverApplyFrame(extra, vec); + UNPROTECT(saveExtras); + exactCallFromClo(clo); + } + } break; + case VALUE_TYPE_KONT: { + if (callable.val.kont == NULL) { + state.C = END_CONTROL; + } else { + Value result = pop(); + protectValue(result); + Kont *kont = callable.val.kont; + state.C = kont->C; + state.K = kont->K; + state.E = kont->E; + restoreKont(state.S, kont); + push(result); + } + } break; + case VALUE_TYPE_BUILTIN: { + BuiltInImplementation *impl = callable.val.builtIn; + if (naargs == impl->nArgs) { + BuiltInFunction fn = (BuiltInFunction)impl->implementation; + Vec *v = newVec(impl->nArgs); + int save = PROTECT(v); + copyValues( + v->entries, + &(state.S->entries[totalSizeStack(state.S) - impl->nArgs]), + impl->nArgs); + Value res = fn(v); + protectValue(res); + state.S->offset -= impl->nArgs; + push(res); + UNPROTECT(save); + } else if (naargs == 0) { + push(callable); + } else { + cant_happen( + "curried built-ins not supported yet (expected %d got %d)", + impl->nArgs, naargs); + } + } break; + default: + cant_happen("unexpected type %s in APPLY", + valueTypeName(callable.type)); } UNPROTECT(save); } @@ -588,11 +601,21 @@ void reportSteps(void) { } #ifdef DEBUG_STEP -static void dumpApplyStats(void) { - eprintf("APPLY stats => exact:%lu partial:%lu over:%lu\n", apply_exact_calls, apply_partial_creations, apply_over_attempts); +__attribute__((unused)) static void dumpApplyStats(void) { + eprintf("APPLY stats => exact:%lu partial:%lu over:%lu\n", + apply_exact_calls, apply_partial_creations, apply_over_attempts); } #endif +__attribute__((unused)) static int failStackSize(Fail *f) { + int size = 0; + while (f != NULL) { + size++; + f = f->F; + } + return size; +} + static void step() { if (dump_bytecode_flag) dumpByteCode(&state.B, state.L); @@ -602,695 +625,655 @@ static void step() { ++count; int bytecode; #ifdef DEBUG_STEP - dumpStack(state.S); + // dumpStack(state.S); // printf("%4ld) %04lx ### ", count, state.C); printf("%04lx ### ", state.C); #endif switch (bytecode = readCurrentByte()) { - case BYTECODES_TYPE_NONE:{ - cant_happen("encountered NONE in step()"); - } - break; - - case BYTECODES_TYPE_LAM:{ - // create a closure and push it - int nArgs = readCurrentByte(); - int letRecOffset = readCurrentByte(); - int end = readCurrentOffset(); - DEBUG("LAM nArgs:[%d] letrec:[%d] end:[%04x]", - nArgs, letRecOffset, end); - Clo *clo = newClo(nArgs, state.C, state.E); - int save = PROTECT(clo); - snapshotClo(clo, state.S, letRecOffset); - Value v = value_Clo(clo); - push(v); - UNPROTECT(save); - state.C = end; - } - break; - - case BYTECODES_TYPE_VAR:{ - // look up an environment variable and push it - int frame = readCurrentByte(); - int offset = readCurrentByte(); - Value v = lookUp(frame, offset); - DEBUG("VAR [%d:%d] == %s", frame, offset, valueTypeName(v.type)); - push(v); - } - break; - - case BYTECODES_TYPE_LVAR:{ - // look up a stack variable and push it - int offset = readCurrentByte(); - Value v = peek(offset); - DEBUG("LVAR [%d] == %s", offset, valueTypeName(v.type)); - push(v); - } - break; - - case BYTECODES_TYPE_PUSHN:{ - // allocate space for n variables on the stack - int size = readCurrentByte(); - DEBUG("PUSHN [%d]", size); - extend(size); - } - break; - - case BYTECODES_TYPE_PRIM_CMP:{ - // pop two values, perform the binop and push the result - DEBUG("CMP"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(vcmp(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_ADD:{ - // pop two values, perform the binop and push the result - DEBUG("ADD"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - Value res = nadd(left, right); - protectValue(res); - push(res); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_SUB:{ - // pop two values, perform the binop and push the result - DEBUG("SUB"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - Value res = nsub(left, right); - protectValue(res); - push(res); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_MUL:{ - // pop two values, perform the binop and push the result - DEBUG("MUL"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - Value res = nmul(left, right); - protectValue(res); - push(res); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_DIV:{ - // pop two values, perform the binop and push the result - DEBUG("DIV"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - Value res = ndiv(left, right); - protectValue(res); - push(res); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_POW:{ - // pop two values, perform the binop and push the result - DEBUG("POW"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - Value res = npow(left, right); - protectValue(res); - push(res); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_MOD:{ - // pop two values, perform the binop and push the result - DEBUG("MOD"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - Value res = nmod(left, right); - protectValue(res); - push(res); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_EQ:{ - // pop two values, perform the binop and push the result - DEBUG("EQ"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(eq(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_NE:{ - // pop two values, perform the binop and push the result - DEBUG("NE"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(ne(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_GT:{ - // pop two values, perform the binop and push the result - DEBUG("GT"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(gt(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_LT:{ - // pop two values, perform the binop and push the result - DEBUG("LT"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(lt(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_GE:{ - // pop two values, perform the binop and push the result - DEBUG("GE"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(ge(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_LE:{ - // pop two values, perform the binop and push the result - DEBUG("LE"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(le(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_VEC:{ - // index, vector => value at index - DEBUG("VEC"); - Value b = pop(); - int save = protectValue(b); - Value a = pop(); - protectValue(a); - Value result = vec(a, b); - protectValue(result); - push(result); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_MAKEVEC:{ - int size = readCurrentByte(); - DEBUG("MAKEVEC [%d]", size); - // at this point there will be `size` arguments on the stack. Rather than - // popping then individually we can just memcpy them into a new struct Vec - Vec *v = newVec(size); - int save = PROTECT(v); - copyToVec(v); - popn(size); - Value val = value_Vec(v); - push(val); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_APPLY:{ - // apply the callable at the top of the stack to the arguments beneath it - int nArgs = readCurrentByte(); - DEBUG("APPLY [%d]", nArgs); - applyProc(nArgs); - } - break; - - case BYTECODES_TYPE_IF:{ - // pop the test result and jump to the appropriate branch - int branch = readCurrentOffset(); - DEBUG("IF [%04x]", branch); - Value aexp = pop(); - if (!truthy(aexp)) { - state.C = branch; - } - } - break; + case BYTECODES_TYPE_NONE: { + cant_happen("encountered NONE in step(%04lx)", state.C - 1); + } break; + + case BYTECODES_TYPE_LAM: { + // create a closure and push it + int nArgs = readCurrentByte(); + int letRecOffset = readCurrentByte(); + int end = readCurrentOffset(); + DEBUG("LAM nArgs:[%d] letrec:[%d] end:[%04x]", nArgs, letRecOffset, + end); + Clo *clo = newClo(nArgs, state.C, state.E); + int save = PROTECT(clo); + snapshotClo(clo, state.S, letRecOffset); + Value v = value_Clo(clo); + push(v); + UNPROTECT(save); + state.C = end; + } break; + + case BYTECODES_TYPE_VAR: { + // look up an environment variable and push it + int frame = readCurrentByte(); + int offset = readCurrentByte(); + Value v = lookUp(frame, offset); + DEBUG("VAR [%d:%d] == %s", frame, offset, valueTypeName(v.type)); + push(v); + } break; + + case BYTECODES_TYPE_LVAR: { + // look up a stack variable and push it + int offset = readCurrentByte(); + Value v = peek(offset); + DEBUG("LVAR [%d] == %s", offset, valueTypeName(v.type)); + push(v); + } break; + + case BYTECODES_TYPE_PUSHN: { + // allocate space for n variables on the stack + int size = readCurrentByte(); + DEBUG("PUSHN [%d]", size); + extend(size); + } break; + + case BYTECODES_TYPE_PRIM_CMP: { + // pop two values, perform the binop and push the result + DEBUG("CMP"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + push(vcmp(left, right)); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_ADD: { + // pop two values, perform the binop and push the result + DEBUG("ADD"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + Value res = nadd(left, right); + protectValue(res); + push(res); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_SUB: { + // pop two values, perform the binop and push the result + DEBUG("SUB"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + Value res = nsub(left, right); + protectValue(res); + push(res); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_MUL: { + // pop two values, perform the binop and push the result + DEBUG("MUL"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + Value res = nmul(left, right); + protectValue(res); + push(res); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_DIV: { + // pop two values, perform the binop and push the result + DEBUG("DIV"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + Value res = ndiv(left, right); + protectValue(res); + push(res); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_POW: { + // pop two values, perform the binop and push the result + DEBUG("POW"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + Value res = npow(left, right); + protectValue(res); + push(res); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_MOD: { + // pop two values, perform the binop and push the result + DEBUG("MOD"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + Value res = nmod(left, right); + protectValue(res); + push(res); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_EQ: { + // pop two values, perform the binop and push the result + DEBUG("EQ"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + push(eq(left, right)); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_NE: { + // pop two values, perform the binop and push the result + DEBUG("NE"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + push(ne(left, right)); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_GT: { + // pop two values, perform the binop and push the result + DEBUG("GT"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + push(gt(left, right)); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_LT: { + // pop two values, perform the binop and push the result + DEBUG("LT"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + push(lt(left, right)); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_GE: { + // pop two values, perform the binop and push the result + DEBUG("GE"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + push(ge(left, right)); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_LE: { + // pop two values, perform the binop and push the result + DEBUG("LE"); + Value right = pop(); + int save = protectValue(right); + Value left = pop(); + protectValue(left); + push(le(left, right)); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_VEC: { + // index, vector => value at index + DEBUG("VEC"); + Value b = pop(); + int save = protectValue(b); + Value a = pop(); + protectValue(a); + Value result = vec(a, b); + protectValue(result); + push(result); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_PRIM_MAKEVEC: { + int size = readCurrentByte(); + DEBUG("MAKEVEC [%d]", size); + // at this point there will be `size` arguments on the stack. Rather + // than popping then individually we can just memcpy them into a new + // struct Vec + Vec *v = newVec(size); + int save = PROTECT(v); + copyToVec(v); + popn(size); + Value val = value_Vec(v); + push(val); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_APPLY: { + // apply the callable at the top of the stack to the arguments + // beneath it + int nArgs = readCurrentByte(); + DEBUG("APPLY [%d]", nArgs); + applyProc(nArgs); + } break; + + case BYTECODES_TYPE_IF: { + // pop the test result and jump to the appropriate branch + int branch = readCurrentOffset(); + DEBUG("IF [%04x]", branch); + Value aexp = pop(); + if (!truthy(aexp)) { + state.C = branch; + } + } break; - case BYTECODES_TYPE_MATCH:{ - // pop the dispach code, verify it's an integer and in range, and dispatch - int size __attribute__((unused)) = readCurrentByte(); + case BYTECODES_TYPE_MATCH: { + // pop the dispach code, verify it's an integer and in range, and + // dispatch + int size __attribute__((unused)) = readCurrentByte(); #ifdef DEBUG_STEP - printf("MATCH [%d]", size); - int save = state.C; - for (int C = 0; C < size; C++) { - printf("[%04x]", readCurrentOffset()); - } - state.C = save; - printf("\n"); + printf("MATCH [%d]", size); + int save = state.C; + for (int C = 0; C < size; C++) { + printf("[%04x]", readCurrentOffset()); + } + state.C = save; + printf("\n"); #endif - Value v = pop(); + Value v = pop(); #ifdef SAFETY_CHECKS - if (v.type != VALUE_TYPE_STDINT) - cant_happen - ("match expression must be an integer, got %s at %lx", - valueTypeName(v.type), state.C); - if (v.val.stdint < 0 || v.val.stdint >= size) - cant_happen - ("match expression index out of range (%d)", - v.val.stdint); + if (v.type != VALUE_TYPE_STDINT) + cant_happen( + "match expression must be an integer, got %s at %lx", + valueTypeName(v.type), state.C); + if (v.val.stdint < 0 || v.val.stdint >= size) + cant_happen("match expression index out of range (%d)", + v.val.stdint); #endif - state.C = readCurrentOffsetAt(v.val.stdint); - } - break; + state.C = readCurrentOffsetAt(v.val.stdint); + } break; - case BYTECODES_TYPE_INTCOND:{ - // pop the value, walk the dispatch table looking for a match, or run the default - int size = readCurrentWord(); + case BYTECODES_TYPE_INTCOND: { + // pop the value, walk the dispatch table looking for a match, or + // run the default + int size = readCurrentWord(); #ifdef DEBUG_STEP - printf("INTCOND [%d]", size); - int here = state.C; - for (int C = 0; C < size; C++) { - printf(" "); - switch(readCurrentByte()) { - case BYTECODES_TYPE_BIGINT: { - BigInt *bigInt = readCurrentBigInt(); - fprintBigInt(stdout, bigInt); - } - break; - case BYTECODES_TYPE_STDINT: { - Integer Int = readCurrentInt(); - printf("%d", Int); - } - break; - default: - cant_happen("expected int or bigint in INTCOND cases"); - } - int offset = readCurrentOffset(); - printf(":[%04x]", offset); - } - printf("\n"); - state.C = here; + printf("INTCOND [%d]", size); + int here = state.C; + for (int C = 0; C < size; C++) { + printf(" "); + switch (readCurrentByte()) { + case BYTECODES_TYPE_BIGINT: { + BigInt *bigInt = readCurrentBigInt(); + fprintBigInt(stdout, bigInt); + } break; + case BYTECODES_TYPE_STDINT: { + Integer Int = readCurrentInt(); + printf("%d", Int); + } break; + default: + cant_happen("expected int or bigint in INTCOND cases"); + } + int offset = readCurrentOffset(); + printf(":[%04x]", offset); + } + printf("\n"); + state.C = here; #endif - Value v = pop(); - int save = protectValue(v); - for (int C = 0; C < size; C++) { - switch(readCurrentByte()) { - case BYTECODES_TYPE_BIGINT: { - BigInt *bigInt = readCurrentBigInt(); - PROTECT(bigInt); - Value u = value_Bigint(bigInt); - protectValue(u); - int offset = readCurrentOffset(); - if (ncmp(u, v) == CMP_EQ) { - state.C = offset; - goto FINISHED_INTCOND; - } - } - break; - case BYTECODES_TYPE_STDINT: { - Integer option = readCurrentInt(); - Value u = value_Stdint(option); - int offset = readCurrentOffset(); - if (ncmp(u, v) == CMP_EQ) { - state.C = offset; - goto FINISHED_INTCOND; - } - } - break; - case BYTECODES_TYPE_IRRATIONAL: { - Double option = readCurrentIrrational(); - Value u = value_Irrational(option); - int offset = readCurrentOffset(); - if (ncmp(u, v) == CMP_EQ) { - state.C = offset; - goto FINISHED_INTCOND; - } - } - break; - default: - cant_happen("expected int or bigint in INTCOND cases"); - } + Value v = pop(); + int save = protectValue(v); + for (int C = 0; C < size; C++) { + enum ByteCodes type = readCurrentByte(); + switch (type) { + case BYTECODES_TYPE_BIGINT: { + BigInt *bigInt = readCurrentBigInt(); + PROTECT(bigInt); + Value u = value_Bigint(bigInt); + protectValue(u); + int offset = readCurrentOffset(); + if (ncmp(u, v) == CMP_EQ) { + state.C = offset; + goto FINISHED_INTCOND; + } + } break; + case BYTECODES_TYPE_STDINT: { + Integer option = readCurrentInt(); + Value u = value_Stdint(option); + int offset = readCurrentOffset(); + if (ncmp(u, v) == CMP_EQ) { + state.C = offset; + goto FINISHED_INTCOND; } - FINISHED_INTCOND: - UNPROTECT(save); + } break; + case BYTECODES_TYPE_IRRATIONAL: { + Double option = readCurrentIrrational(); + Value u = value_Irrational(option); + int offset = readCurrentOffset(); + if (ncmp(u, v) == CMP_EQ) { + state.C = offset; + goto FINISHED_INTCOND; + } + } break; + default: + cant_happen("unexpected %s in INTCOND cases", + byteCodesName(type)); } - break; - - case BYTECODES_TYPE_CHARCOND:{ - // pop the value, walk the dispatch table looking for a match, or run the default - int size = readCurrentWord(); + } + FINISHED_INTCOND: + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_CHARCOND: { + // pop the value, walk the dispatch table looking for a match, or + // run the default + int size = readCurrentWord(); #ifdef DEBUG_STEP - printf("CHARCOND [%d]", size); - int here = state.C; - for (int C = 0; C < size; C++) { - Integer val = readCurrentInt(); - int offset = readCurrentOffset(); - printf(" %d:[%04x]", val, offset); - } - printf("\n"); - state.C = here; + printf("CHARCOND [%d]", size); + int here = state.C; + for (int C = 0; C < size; C++) { + Integer val = readCurrentInt(); + int offset = readCurrentOffset(); + printf(" %d:[%04x]", val, offset); + } + printf("\n"); + state.C = here; #endif - Value v = pop(); - switch (v.type) { - case VALUE_TYPE_STDINT: - for (int C = 0; C < size; C++) { - Integer val = readCurrentInt(); - int offset = readCurrentOffset(); - if (v.val.stdint == val) { - state.C = offset; - break; - } - } - break; - case VALUE_TYPE_CHARACTER: - for (int C = 0; C < size; C++) { - Character val = readCurrentCharacter(); - int offset = readCurrentOffset(); - if (v.val.character == val) { - state.C = offset; - break; - } - } - break; - default: - cant_happen - ("unexpected type %d for CHARCOND value", - v.type); + Value v = pop(); + switch (v.type) { + case VALUE_TYPE_STDINT: + for (int C = 0; C < size; C++) { + Integer val = readCurrentInt(); + int offset = readCurrentOffset(); + if (v.val.stdint == val) { + state.C = offset; + break; } } break; - - case BYTECODES_TYPE_LETREC:{ - // patch each of the lambdas environments with the current stack frame - // i.e. all the definitions in the current letrec. - int nArgs = readCurrentByte(); - DEBUG("LETREC [%d] state.S->offset = %d", nArgs, state.S->offset); - for (Index i = state.S->offset - nArgs; i < state.S->offset; i++) { - Value v = peek(i); - if (v.type == VALUE_TYPE_CLO) { - patchClo(v.val.clo, state.S); - } else { - cant_happen("non-lambda value (%d) for letrec", v.type); - } + case VALUE_TYPE_CHARACTER: + for (int C = 0; C < size; C++) { + Character val = readCurrentCharacter(); + int offset = readCurrentOffset(); + if (v.val.character == val) { + state.C = offset; + break; } } break; - - case BYTECODES_TYPE_AMB:{ - // create a new failure continuation to resume at the alternative - int branch = readCurrentOffset(); - DEBUG("AMB [%04x]", branch); - state.F = makeFail(branch, state.E, state.K, state.F); - snapshotFail(state.F, state.S); + default: + cant_happen("unexpected type %s for CHARCOND value", + valueTypeName(v.type)); + } + } break; + + case BYTECODES_TYPE_LETREC: { + // patch each of the lambdas environments with the current stack + // frame i.e. all the definitions in the current letrec. + int nArgs = readCurrentByte(); + DEBUG("LETREC [%d] state.S->offset = %d", nArgs, state.S->offset); + for (Index i = state.S->offset - nArgs; i < state.S->offset; i++) { + Value v = peek(i); + if (v.type == VALUE_TYPE_CLO) { + patchClo(v.val.clo, state.S); + } else { + cant_happen("non-lambda value (%s) for letrec", + valueTypeName(v.type)); } - break; - - case BYTECODES_TYPE_CUT:{ - // discard the current failure continuation - DEBUG("CUT"); + } + } break; + + case BYTECODES_TYPE_AMB: { + // create a new failure continuation to resume at the alternative + int branch = readCurrentOffset(); + DEBUG("AMB [%04x]", branch); + state.F = makeFail(branch, state.E, state.K, state.F); + snapshotFail(state.F, state.S); + } break; + + case BYTECODES_TYPE_CUT: { + // discard the current failure continuation + DEBUG("CUT"); #ifdef SAFETY_CHECKS - if (state.F == NULL) { - cant_happen - ("cut with no extant failure continuation"); - } + if (state.F == NULL) { + cant_happen("cut with no extant failure continuation"); + } #endif - state.F = state.F->F; - } - break; - - case BYTECODES_TYPE_BACK:{ - // restore the failure continuation or halt - DEBUG("BACK"); - if (state.F == NULL) { - state.C = END_CONTROL; - } else { - state.C = state.F->C; - state.E = state.F->E; - state.K = state.F->K; - restoreFail(state.S, state.F); - state.F = state.F->F; - } - } - break; - - case BYTECODES_TYPE_LET:{ - // create a new continuation to resume the body, and transfer control to the expression - int offset = readCurrentOffset(); - DEBUG("LET [%04x]", offset); - letStackFrame(state.S); - state.K = makeKont(offset, state.E, false, state.K); - validateLastAlloc(); - } - break; - - case BYTECODES_TYPE_JMP:{ - // jump forward a specified amount - int offset = readCurrentOffset(); - DEBUG("JMP [%04x]", offset); - state.C = offset; - } - break; - - case BYTECODES_TYPE_CALLCC:{ - // pop the callable, push the current continuation, push the callable and apply - DEBUG("CALLCC"); - Value aexp = pop(); - int save = protectValue(aexp); - Value cc = captureKont(); - protectValue(cc); - push(cc); - push(aexp); - UNPROTECT(save); - applyProc(1); - } - break; - - case BYTECODES_TYPE_IRRATIONAL:{ - // push literal Double - Double f = readCurrentIrrational(); - DEBUG("IRRATIONAL [%f]", f); - Value v = value_Irrational(f); - push(v); - } - break; - - case BYTECODES_TYPE_IRRATIONAL_IMAG:{ - // push literal Double - Double f = readCurrentIrrational(); - DEBUG("IRRATIONAL_IMAG [%f]", f); - Value v = value_Irrational_imag(f); - push(v); - } - break; - - case BYTECODES_TYPE_STDINT:{ - // push literal int - Integer val = readCurrentInt(); - DEBUG("STDINT [%d]", val); - Value v = value_Stdint(val); - push(v); - } - break; - - case BYTECODES_TYPE_STDINT_IMAG:{ - // push literal int - Integer val = readCurrentInt(); - DEBUG("STDINT_IMAG [%d]", val); - Value v = value_Stdint_imag(val); - push(v); - } - break; - - case BYTECODES_TYPE_CHAR:{ - // push literal char - Character c = readCurrentCharacter(); - DEBUG("CHAR [%s]", charRep(c)); - Value v = value_Character(c); - push(v); - } - break; - - case BYTECODES_TYPE_BIGINT:{ - BigInt *bigInt = readCurrentBigInt(); - int save = PROTECT(bigInt); + state.F = state.F->F; + } break; + + case BYTECODES_TYPE_BACK: { + // restore the failure continuation or halt + DEBUG("BACK"); + if (state.F == NULL) { + state.C = END_CONTROL; + } else { + state.C = state.F->C; + state.E = state.F->E; + state.K = state.F->K; + restoreFail(state.S, state.F); + state.F = state.F->F; + } + } break; + + case BYTECODES_TYPE_LET: { + // create a new continuation to resume the body, and transfer + // control to the expression + int offset = readCurrentOffset(); + DEBUG("LET [%04x]", offset); + letStackFrame(state.S); + state.K = makeKont(offset, state.E, false, state.K); + validateLastAlloc(); + } break; + + case BYTECODES_TYPE_JMP: { + // jump forward a specified amount + int offset = readCurrentOffset(); + DEBUG("JMP [%04x]", offset); + state.C = offset; + } break; + + case BYTECODES_TYPE_CALLCC: { + // pop the callable, push the current continuation, push the + // callable and apply + DEBUG("CALLCC"); + Value aexp = pop(); + int save = protectValue(aexp); + Value cc = captureKont(); + protectValue(cc); + push(cc); + push(aexp); + UNPROTECT(save); + applyProc(1); + } break; + + case BYTECODES_TYPE_IRRATIONAL: { + // push literal Double + Double f = readCurrentIrrational(); + DEBUG("IRRATIONAL [%f]", f); + Value v = value_Irrational(f); + push(v); + } break; + + case BYTECODES_TYPE_IRRATIONAL_IMAG: { + // push literal Double + Double f = readCurrentIrrational(); + DEBUG("IRRATIONAL_IMAG [%f]", f); + Value v = value_Irrational_imag(f); + push(v); + } break; + + case BYTECODES_TYPE_STDINT: { + // push literal int + Integer val = readCurrentInt(); + DEBUG("STDINT [%d]", val); + Value v = value_Stdint(val); + push(v); + } break; + + case BYTECODES_TYPE_STDINT_IMAG: { + // push literal int + Integer val = readCurrentInt(); + DEBUG("STDINT_IMAG [%d]", val); + Value v = value_Stdint_imag(val); + push(v); + } break; + + case BYTECODES_TYPE_CHAR: { + // push literal char + Character c = readCurrentCharacter(); + DEBUG("CHAR [%s]", charRep(c)); + Value v = value_Character(c); + push(v); + } break; + + case BYTECODES_TYPE_BIGINT: { + BigInt *bigInt = readCurrentBigInt(); + int save = PROTECT(bigInt); #ifdef DEBUG_STEP - printf("BIGINT ["); - fprintBigInt(stdout, bigInt); - printf("]\n"); + printf("BIGINT ["); + fprintBigInt(stdout, bigInt); + printf("]\n"); #endif - Value v = value_Bigint(bigInt); - push(v); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_BIGINT_IMAG:{ - BigInt *bigInt = readCurrentBigInt(); - int save = PROTECT(bigInt); + Value v = value_Bigint(bigInt); + push(v); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_BIGINT_IMAG: { + BigInt *bigInt = readCurrentBigInt(); + int save = PROTECT(bigInt); #ifdef DEBUG_STEP - printf("BIGINT_IMAG ["); - fprintBigInt(stdout, bigInt); - printf("]\n"); + printf("BIGINT_IMAG ["); + fprintBigInt(stdout, bigInt); + printf("]\n"); #endif - Value v = value_Bigint_imag(bigInt); - push(v); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_RETURN:{ - // push the current continuation and apply - DEBUG("RETURN"); - Value kont = value_Kont(state.K); - push(kont); - applyProc(1); - // a RETURN just completed; mark ready for staged over-application only if result is callable - if (overApplyStack->size > 0) { - Value top = peek(-1); - if (top.type == VALUE_TYPE_CLO || top.type == VALUE_TYPE_PCLO) { - peekOverApplyStack(overApplyStack)->ready = true; - } - } - } - break; - - case BYTECODES_TYPE_NS_START:{ - int num = readCurrentWord(); - DEBUG("NS_START [%d]", num); - extend(num); - } - break; - - case BYTECODES_TYPE_NS_END:{ - int numLambdas = readCurrentWord(); - int stackOffset = readCurrentWord(); - DEBUG("NS_END [%d] [%d]", numLambdas, stackOffset); - Vec *snapshot = snapshotNameSpace(state.S); - int save = PROTECT(snapshot); - Value ns = value_NameSpace(snapshot); - poke(0 - (numLambdas + stackOffset), ns); - discard(numLambdas); - UNPROTECT(save); + Value v = value_Bigint_imag(bigInt); + push(v); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_RETURN: { + // push the current continuation and apply + DEBUG("RETURN"); + Value kont = value_Kont(state.K); + push(kont); + applyProc(1); + // a RETURN just completed; mark ready for staged over-application + // only if result is callable + if (overApplyStack->size > 0) { + Value top = peek(-1); + if (top.type == VALUE_TYPE_CLO || top.type == VALUE_TYPE_PCLO) { + peekOverApplyStack(overApplyStack)->ready = true; } - break; - - case BYTECODES_TYPE_NS_FINISH:{ - int num = readCurrentWord(); - DEBUG("NS_FINISH [%d]", num); - // at this point we need to patch each of the nameSpaces with the - // final block of populated nameSpaces, size num, and at TOS - for (int i = 1; i <= num; i++) { - Value ns = peek(-i); + } + } break; + + case BYTECODES_TYPE_NS_START: { + int num = readCurrentWord(); + DEBUG("NS_START [%d]", num); + extend(num); + } break; + + case BYTECODES_TYPE_NS_END: { + int numLambdas = readCurrentWord(); + int stackOffset = readCurrentWord(); + DEBUG("NS_END [%d] [%d]", numLambdas, stackOffset); + Vec *snapshot = snapshotNameSpace(state.S); + int save = PROTECT(snapshot); + Value ns = value_NameSpace(snapshot); + poke(0 - (numLambdas + stackOffset), ns); + discard(numLambdas); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_NS_FINISH: { + int num = readCurrentWord(); + DEBUG("NS_FINISH [%d]", num); + // at this point we need to patch each of the nameSpaces with the + // final block of populated nameSpaces, size num, and at TOS + for (int i = 1; i <= num; i++) { + Value ns = peek(-i); #ifdef SAFETY_CHECKS - if (ns.type != VALUE_TYPE_NAMESPACE) { - cant_happen("expected nameSpace, got %d", ns.type); - } -#endif - patch(ns, num); - } + if (ns.type != VALUE_TYPE_NAMESPACE) { + cant_happen("expected VALUE_TYPE_NAMESPACE, got %s", + valueTypeName(ns.type)); } - break; +#endif + patch(ns, num); + } + } break; - case BYTECODES_TYPE_NS_PUSHSTACK:{ - int offset = readCurrentWord(); - DEBUG("NS_PUSHSTACK [%d]", offset); - Value v = peek(offset); + case BYTECODES_TYPE_NS_PUSHSTACK: { + int offset = readCurrentWord(); + DEBUG("NS_PUSHSTACK [%d]", offset); + Value v = peek(offset); #ifdef SAFETY_CHECKS - if (v.type != VALUE_TYPE_NAMESPACE) { - cant_happen("expected nameSpace, got type %d", v.type); - } + if (v.type != VALUE_TYPE_NAMESPACE) { + cant_happen("expected VALUE_TYPE_NAMESPACE, got %s", + valueTypeName(v.type)); + } #endif - // new empty stack frame - pushStackFrame(state.S); - // copy the nameSpace contents to the top of the stack - restoreNameSpace(state.S, v.val.nameSpace); - } - break; - - case BYTECODES_TYPE_NS_PUSHENV:{ - int frame = readCurrentWord(); - int offset = readCurrentWord(); - DEBUG("NS_PUSHENV [%d][%d]", frame, offset); - Value v = lookUp(frame, offset); + // new empty stack frame + pushStackFrame(state.S); + // copy the nameSpace contents to the top of the stack + restoreNameSpace(state.S, v.val.nameSpace); + } break; + + case BYTECODES_TYPE_NS_PUSHENV: { + int frame = readCurrentWord(); + int offset = readCurrentWord(); + DEBUG("NS_PUSHENV [%d][%d]", frame, offset); + Value v = lookUp(frame, offset); #ifdef SAFETY_CHECKS - if (v.type != VALUE_TYPE_NAMESPACE) { - cant_happen("expected nameSpace, got type %d", v.type); - } + if (v.type != VALUE_TYPE_NAMESPACE) { + cant_happen("expected VALUE_TYPE_NAMESPACE, got %s", + valueTypeName(v.type)); + } #endif - // new empty stack frame - pushStackFrame(state.S); - // copy the nameSpace contents to the top of the stack - restoreNameSpace(state.S, v.val.nameSpace); - } - break; + // new empty stack frame + pushStackFrame(state.S); + // copy the nameSpace contents to the top of the stack + restoreNameSpace(state.S, v.val.nameSpace); + } break; + + case BYTECODES_TYPE_NS_POP: { + DEBUG("NS_POP"); + Value result = pop(); + int save = protectValue(result); + // remove the top stack frame + popStackFrame(state.S); + push(result); + UNPROTECT(save); + } break; + + case BYTECODES_TYPE_DONE: { + // can't happen, probably + DEBUG("DONE"); + state.C = END_CONTROL; + } break; + + case BYTECODES_TYPE_ERROR: { + DEBUG("ERROR"); + state.C = END_CONTROL; + eprintf("pattern match exhausted in step\n"); + } break; - case BYTECODES_TYPE_NS_POP:{ - DEBUG("NS_POP"); - Value result = pop(); - int save = protectValue(result); - // remove the top stack frame - popStackFrame(state.S); - push(result); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_DONE:{ - // can't happen, probably - DEBUG("DONE"); - state.C = END_CONTROL; - } - break; - - case BYTECODES_TYPE_ERROR:{ - DEBUG("ERROR"); - state.C = END_CONTROL; - eprintf("pattern match exhausted in step\n"); - } - break; - - default: - cant_happen("unrecognised bytecode %d in step()", bytecode); + default: + cant_happen("unrecognised bytecode %s in step()", + byteCodesName(bytecode)); } - // Resume staged over-application if active and a callable result is on stack - // (old single-frame logic removed) - if (overApplyStack->size > 0) { + // Resume staged over-application if active and a callable result is on + // stack + // (old single-frame logic removed) + if (overApplyStack->size > 0) { OverApplyFrame *f = peekOverApplyStack(overApplyStack); while (f->ready && f->index < f->count) { Value top = peek(-1); @@ -1310,26 +1293,28 @@ static void step() { // Still unwinding continuation; break and wait break; } else { - cant_happen("expected VALUE_TYPE_CLO or VALUE_TYPE_PCLO, got %s", valueTypeName(top.type)); + cant_happen( + "expected VALUE_TYPE_CLO or VALUE_TYPE_PCLO, got %s", + valueTypeName(top.type)); break; } if (f->index == f->count) { popOverApplyFrame(); - if (overApplyStack->size == 0) break; + if (overApplyStack->size == 0) + break; f = peekOverApplyStack(overApplyStack); } } - } - // end instruction loop iteration + } + // end instruction loop iteration #ifdef DEBUG_STEP -# ifdef DEBUG_SLOW_STEP +#ifdef DEBUG_SLOW_STEP sleep(1); -# endif +#endif #endif } } - void putCharacter(Character c) { char buf[MB_LEN_MAX]; int len = wctomb(buf, c); diff --git a/src/tc_analyze.c b/src/tc_analyze.c index b92c6c84..1cc3a3b4 100644 --- a/src/tc_analyze.c +++ b/src/tc_analyze.c @@ -18,90 +18,101 @@ #include -#include "tc_analyze.h" -#include "symbols.h" -#include "symbol.h" -#include "memory.h" #include "hash.h" -#include "tc_debug.h" -#include "tc_helper.h" +#include "lambda_pp.h" +#include "memory.h" #include "print_compiler.h" #include "print_generator.h" -#include "lambda_pp.h" +#include "symbol.h" +#include "symbols.h" +#include "tc_analyze.h" +#include "tc_debug.h" +#include "tc_helper.h" #include "types.h" #ifdef DEBUG_TC -# include "debugging_on.h" -# include "lambda_pp.h" +#include "debugging_on.h" +#include "lambda_pp.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif -static void addToEnv(TcEnv * env, HashSymbol * key, TcType * type); -static void addToNg(TcNg * env, TcType * type); -static void addFreshVarToEnv(TcEnv * env, HashSymbol * key); -static void addCmpToEnv(TcEnv * env, HashSymbol * key); -static void addBuiltinsToEnv(TcEnv * env, BuiltIns * builtIns); -static void addNameSpacesToEnv(TcEnv * env); +static void addToEnv(TcEnv *env, HashSymbol *key, TcType *type); +static void addToNg(TcNg *env, TcType *type); +static void addFreshVarToEnv(TcEnv *env, HashSymbol *key); +static void addCmpToEnv(TcEnv *env, HashSymbol *key); +static void addBuiltinsToEnv(TcEnv *env, BuiltIns *builtIns); +static void addNameSpacesToEnv(TcEnv *env); static TcType *makeSpaceship(void); static TcType *makeBigInteger(void); static TcType *makeCharacter(void); -static TcType *makeUnknown(HashSymbol * var); -static TcType *makeVar(HashSymbol * t); -static TcType *makeFn(TcType * arg, TcType * result); -static TcType *makeThunk(TcType * type); +static TcType *makeUnknown(HashSymbol *var); +static TcType *makeVar(HashSymbol *t); +static TcType *makeFn(TcType *arg, TcType *result); +static TcType *makeThunk(TcType *type); static TcType *makeTuple(int size); -static void addHereToEnv(TcEnv * env); -static void addIfToEnv(TcEnv * env); -static void addIntBinOpToEnv(TcEnv * env, HashSymbol * symbol); -static void addNegToEnv(TcEnv * env); -static void addThenToEnv(TcEnv * env); -static TcType *analyzeExp(LamExp * exp, TcEnv * env, TcNg * ng); -static TcType *analyzeLam(LamLam * lam, TcEnv * env, TcNg * ng); -static TcType *analyzeVar(ParserInfo I, HashSymbol * var, TcEnv * env, TcNg * ng); +static void addHereToEnv(TcEnv *env); +static void addIfToEnv(TcEnv *env); +static void addIntBinOpToEnv(TcEnv *env, HashSymbol *symbol); +static void addNegToEnv(TcEnv *env); +static void addThenToEnv(TcEnv *env); +static TcType *analyzeExp(LamExp *exp, TcEnv *env, TcNg *ng); +static TcType *analyzeLam(LamLam *lam, TcEnv *env, TcNg *ng); +static TcType *analyzeVar(ParserInfo I, HashSymbol *var, TcEnv *env, TcNg *ng); static TcType *analyzeSmallInteger(); static TcType *analyzeBigInteger(); -static TcType *analyzePrim(LamPrimApp * app, TcEnv * env, TcNg * ng); -static TcType *analyzeSequence(LamSequence * sequence, TcEnv * env, TcNg * ng); -static TcType *analyzeConstruct(LamConstruct * construct, TcEnv * env, TcNg * ng); -static TcType *analyzeDeconstruct(LamDeconstruct * deconstruct, TcEnv * env, TcNg * ng); -static TcType *analyzeTag(LamExp * tag, TcEnv * env, TcNg * ng); -static TcType *analyzeConstant(LamConstant * constant, TcEnv * env, TcNg * ng); -static TcType *analyzeApply(LamApply * apply, TcEnv * env, TcNg * ng); -static TcType *analyzeIff(LamIff * iff, TcEnv * env, TcNg * ng); -static TcType *analyzeCallCC(LamExp * called, TcEnv * env, TcNg * ng); -static TcType *analyzePrint(LamPrint * print, TcEnv * env, TcNg * ng); -static TcType *analyzeTypeDefs(LamTypeDefs * typeDefs, TcEnv * env, TcNg * ng); -static TcType *analyzeLet(LamLet * let, TcEnv * env, TcNg * ng); -static TcType *analyzeLetRec(LamLetRec * letRec, TcEnv * env, TcNg * ng); +static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng); +static TcType *analyzeSequence(LamSequence *sequence, TcEnv *env, TcNg *ng); +static TcType *analyzeConstruct(LamConstruct *construct, TcEnv *env, TcNg *ng); +static TcType *analyzeDeconstruct(LamDeconstruct *deconstruct, TcEnv *env, + TcNg *ng); +static TcType *analyzeTag(LamExp *tag, TcEnv *env, TcNg *ng); +static TcType *analyzeConstant(LamConstant *constant, TcEnv *env, TcNg *ng); +static TcType *analyzeApply(LamApply *apply, TcEnv *env, TcNg *ng); +static TcType *analyzeIff(LamIff *iff, TcEnv *env, TcNg *ng); +static TcType *analyzeCallCC(LamExp *called, TcEnv *env, TcNg *ng); +static TcType *analyzePrint(LamPrint *print, TcEnv *env, TcNg *ng); +static TcType *analyzeTypeDefs(LamTypeDefs *typeDefs, TcEnv *env, TcNg *ng); +static TcType *analyzeLet(LamLet *let, TcEnv *env, TcNg *ng); +static TcType *analyzeLetRec(LamLetRec *letRec, TcEnv *env, TcNg *ng); static TcType *analyzeLetStar(LamLetStar *letStar, TcEnv *env, TcNg *ng); -static TcType *analyzeMatch(LamMatch * match, TcEnv * env, TcNg * ng); -static TcType *analyzeCond(LamCond * cond, TcEnv * env, TcNg * ng); -static TcType *analyzeAmb(LamAmb * amb, TcEnv * env, TcNg * ng); -static TcType *analyzeTupleIndex(LamTupleIndex * index, TcEnv * env, TcNg * ng); -static TcType *analyzeMakeTuple(LamArgs * tuple, TcEnv * env, TcNg * ng); -static TcType *analyzeNameSpaces(LamNameSpaceArray * nsArray, TcEnv * env, TcNg * ng); +static TcType *analyzeMatch(LamMatch *match, TcEnv *env, TcNg *ng); +static TcType *analyzeCond(LamCond *cond, TcEnv *env, TcNg *ng); +static TcType *analyzeAmb(LamAmb *amb, TcEnv *env, TcNg *ng); +static TcType *analyzeTupleIndex(LamTupleIndex *index, TcEnv *env, TcNg *ng); +static TcType *analyzeMakeTuple(LamArgs *tuple, TcEnv *env, TcNg *ng); +static TcType *analyzeNameSpaces(LamNameSpaceArray *nsArray, TcEnv *env, + TcNg *ng); static TcType *analyzeCharacter(); static TcType *analyzeBack(); static TcType *analyzeError(); -static TcType *analyzeEnv(TcEnv * env); -static bool unify(TcType * a, TcType * b, char *trace __attribute__((unused))); -static TcType *prune(TcType * t); -static bool occursInType(TcType * a, TcType * b); -static bool occursIn(TcType * a, TcType * b); -static bool sameType(TcType * a, TcType * b); -static TcType *analyzeBigIntegerExp(LamExp * exp, TcEnv * env, TcNg * ng); -static TcType *analyzeSmallIntegerExp(LamExp * exp, TcEnv * env, TcNg * ng) __attribute__((unused)); -static TcType *analyzeBooleanExp(LamExp * exp, TcEnv * env, TcNg * ng); -static TcType *freshRec(TcType * type, TcNg * ng, TcTypeTable * map); -static TcType *lookUp(TcEnv * env, HashSymbol * symbol, TcNg * ng); +static TcType *analyzeEnv(TcEnv *env); +static TcEnv *getNsEnv(int index, TcEnv *env); +static LamExp *lookupComparator(TcType *type, TcEnv *env, ParserInfo I); +static bool isEqFunction(HashSymbol *symbol); +static HashSymbol *extractTypename(HashSymbol *eqSymbol, const char *prefix); +static TcType *makeEqFunctionType(HashSymbol *typename, TcEnv *env, + ParserInfo I); +static bool unify(TcType *a, TcType *b, char *trace __attribute__((unused))); +static TcType *prune(TcType *t); +static bool occursInType(TcType *a, TcType *b); +static bool occursIn(TcType *a, TcType *b); +static bool sameType(TcType *a, TcType *b); +static TcType *analyzeBigIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng); +static TcType *analyzeSmallIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng) + __attribute__((unused)); +static TcType *analyzeBooleanExp(LamExp *exp, TcEnv *env, TcNg *ng); +static TcType *freshRec(TcType *type, TcNg *ng, TcTypeTable *map); +static TcType *lookUp(TcEnv *env, HashSymbol *symbol, TcNg *ng); static TcType *analyzeLookUp(LamLookUp *, TcEnv *, TcNg *); -static TcType *lookUpConstructorType(HashSymbol * name, int nameSpace, TcEnv * env, TcNg * ng); -static void addTypeSigToEnv(TcEnv * env, HashSymbol * symbol, TcTypeSig * type); +static TcType *lookUpConstructorType(HashSymbol *name, int nameSpace, + TcEnv *env, TcNg *ng); +static void addTypeSigToEnv(TcEnv *env, HashSymbol *symbol, TcTypeSig *type); static bool failUnify(TcType *a, TcType *b, char *reason); static bool failUnifyTypeSigs(TcTypeSig *a, TcTypeSig *b, char *reason); -static bool failUnifyFunctions(TcFunction *a, TcFunction *b, char *reason) __attribute__((unused)); -bool getTypeSigFromTcEnv(TcEnv * env, HashSymbol * symbol, TcTypeSig ** type); +static bool failUnifyFunctions(TcFunction *a, TcFunction *b, char *reason) + __attribute__((unused)); +bool getTypeSigFromTcEnv(TcEnv *env, HashSymbol *symbol, TcTypeSig **type); static int id_counter = 0; @@ -145,9 +156,7 @@ TcType *tc_analyze(LamExp *exp, TcEnv *env) { TcType *makeListType(TcType *content) { TcTypeSigArgs *args = newTcTypeSigArgs(content, NULL); int save = PROTECT(args); - TcTypeSig *typeSig = newTcTypeSig(newSymbol("list"), args, -1); - PROTECT(typeSig); - TcType *res = newTcType_TypeSig(typeSig); + TcType *res = makeTcType_TypeSig(newSymbol("list"), args, -1); UNPROTECT(save); return res; } @@ -155,9 +164,7 @@ TcType *makeListType(TcType *content) { TcType *makeMaybeType(TcType *content) { TcTypeSigArgs *args = newTcTypeSigArgs(content, NULL); int save = PROTECT(args); - TcTypeSig *typeSig = newTcTypeSig(newSymbol("maybe"), args, -1); - PROTECT(typeSig); - TcType *res = newTcType_TypeSig(typeSig); + TcType *res = makeTcType_TypeSig(newSymbol("maybe"), args, -1); UNPROTECT(save); return res; } @@ -170,14 +177,13 @@ TcType *makeMaybeStringType() { return maybeStringType; } +// used by builtins TcType *makeTryType(TcType *failure, TcType *success) { TcTypeSigArgs *args = newTcTypeSigArgs(success, NULL); int save = PROTECT(args); args = newTcTypeSigArgs(failure, args); PROTECT(args); - TcTypeSig *typeSig = newTcTypeSig(newSymbol("try"), args, -1); - PROTECT(typeSig); - TcType *res = newTcType_TypeSig(typeSig); + TcType *res = makeTcType_TypeSig(newSymbol("try"), args, -1); UNPROTECT(save); return res; } @@ -191,41 +197,23 @@ TcType *makeStringType(void) { } static TcType *makeNamedType(char *name) { - TcTypeSig *typeSig = newTcTypeSig(newSymbol(name), NULL, -1); - int save = PROTECT(typeSig); - TcType *res = newTcType_TypeSig(typeSig); - UNPROTECT(save); - return res; + return makeTcType_TypeSig(newSymbol(name), NULL, -1); } -TcType *makeBasicType(void) { - return makeNamedType("basic_type"); -} +TcType *makeBasicType(void) { return makeNamedType("basic_type"); } -TcType *makeIOType(void) { - return makeNamedType("io_mode"); -} +TcType *makeIOType(void) { return makeNamedType("io_mode"); } -TcType *makeFTypeType(void) { - return makeNamedType("ftype_type"); -} +TcType *makeFTypeType(void) { return makeNamedType("ftype_type"); } static TcType *analyzeTypeOf(LamExp *exp, TcEnv *env, TcNg *ng) { - // Analyze the inner expression to get its type TcType *type = analyzeExp(getLamExp_TypeOf(exp)->exp, env, ng); int save = PROTECT(type); - // Convert the type to a string representation - char *typeString = tcTypeToString(prune(type)); - // Convert the C string to a lambda list of chars - LamExp *stringExp = stringToLamArgs(CPI(exp), typeString); - PROTECT(stringExp); - free(typeString); // Free the temporary C string - // Replace just the type discriminator and union value, preserving header - exp->type = stringExp->type; - exp->val = stringExp->val; - // Also copy the parser info - exp->_yy_parser_info = CPI(stringExp); - // Create the return type before unprotecting + SCharArray *typeName = tcTypeToSCharArray(prune(type)); + PROTECT(typeName); + pushSCharArray(typeName, '\0'); + getLamExp_TypeOf(exp)->typeString = + stringToLamArgs(CPI(exp), typeName->entries); TcType *stringType = makeStringType(); UNPROTECT(save); return stringType; @@ -235,78 +223,80 @@ static TcType *analyzeExp(LamExp *exp, TcEnv *env, TcNg *ng) { if (exp == NULL) return NULL; switch (exp->type) { - case LAMEXP_TYPE_LAM: - return prune(analyzeLam(getLamExp_Lam(exp), env, ng)); - case LAMEXP_TYPE_VAR: - return prune(analyzeVar(CPI(exp), getLamExp_Var(exp), env, ng)); - case LAMEXP_TYPE_STDINT: - return prune(analyzeSmallInteger()); - case LAMEXP_TYPE_BIGINTEGER: - return prune(analyzeBigInteger()); - case LAMEXP_TYPE_PRIM: - return prune(analyzePrim(getLamExp_Prim(exp), env, ng)); - case LAMEXP_TYPE_SEQUENCE: - return prune(analyzeSequence(getLamExp_Sequence(exp), env, ng)); - case LAMEXP_TYPE_MAKEVEC: - cant_happen("encountered make-vec in analyzeExp"); - case LAMEXP_TYPE_CONSTRUCT: - return prune(analyzeConstruct(getLamExp_Construct(exp), env, ng)); - case LAMEXP_TYPE_DECONSTRUCT: - return prune(analyzeDeconstruct(getLamExp_Deconstruct(exp), env, ng)); - case LAMEXP_TYPE_TAG: - return prune(analyzeTag(getLamExp_Tag(exp), env, ng)); - case LAMEXP_TYPE_CONSTANT: - return prune(analyzeConstant(getLamExp_Constant(exp), env, ng)); - case LAMEXP_TYPE_APPLY: - return prune(analyzeApply(getLamExp_Apply(exp), env, ng)); - case LAMEXP_TYPE_IFF: - return prune(analyzeIff(getLamExp_Iff(exp), env, ng)); - case LAMEXP_TYPE_CALLCC: - return prune(analyzeCallCC(getLamExp_CallCC(exp), env, ng)); - case LAMEXP_TYPE_PRINT: - return prune(analyzePrint(getLamExp_Print(exp), env, ng)); - case LAMEXP_TYPE_TYPEOF: - return analyzeTypeOf(exp, env, ng); - case LAMEXP_TYPE_LETREC: - return prune(analyzeLetRec(getLamExp_LetRec(exp), env, ng)); - case LAMEXP_TYPE_TYPEDEFS: - return prune(analyzeTypeDefs(getLamExp_TypeDefs(exp), env, ng)); - case LAMEXP_TYPE_LET: - return prune(analyzeLet(getLamExp_Let(exp), env, ng)); - case LAMEXP_TYPE_LETSTAR: - return prune(analyzeLetStar(getLamExp_LetStar(exp), env, ng)); - case LAMEXP_TYPE_MATCH: - return prune(analyzeMatch(getLamExp_Match(exp), env, ng)); - case LAMEXP_TYPE_COND: - return prune(analyzeCond(getLamExp_Cond(exp), env, ng)); - case LAMEXP_TYPE_AMB: - return prune(analyzeAmb(getLamExp_Amb(exp), env, ng)); - case LAMEXP_TYPE_CHARACTER: - return prune(analyzeCharacter()); - case LAMEXP_TYPE_BACK: - return prune(analyzeBack()); - case LAMEXP_TYPE_ERROR: - return prune(analyzeError()); - case LAMEXP_TYPE_TUPLEINDEX: - return prune(analyzeTupleIndex(getLamExp_TupleIndex(exp), env, ng)); - case LAMEXP_TYPE_MAKETUPLE: - return prune(analyzeMakeTuple(getLamExp_MakeTuple(exp), env, ng)); - case LAMEXP_TYPE_NAMESPACES: - return prune(analyzeNameSpaces(getLamExp_NameSpaces(exp), env, ng)); - case LAMEXP_TYPE_ENV: - return prune(analyzeEnv(env)); - case LAMEXP_TYPE_LOOKUP: - return prune(analyzeLookUp(getLamExp_LookUp(exp), env, ng)); - case LAMEXP_TYPE_CONSTRUCTOR: - return - prune(analyzeVar - (CPI(exp), getLamExp_Constructor(exp)->name, env, ng)); - default: - cant_happen("unrecognized type %s", lamExpTypeName(exp->type)); - } -} - -static TcType *makeFunctionType(LamVarList *args, TcEnv *env, + case LAMEXP_TYPE_LAM: + return prune(analyzeLam(getLamExp_Lam(exp), env, ng)); + case LAMEXP_TYPE_VAR: + return prune(analyzeVar(CPI(exp), getLamExp_Var(exp), env, ng)); + case LAMEXP_TYPE_STDINT: + return prune(analyzeSmallInteger()); + case LAMEXP_TYPE_BIGINTEGER: + return prune(analyzeBigInteger()); + case LAMEXP_TYPE_PRIM: + return prune(analyzePrim(getLamExp_Prim(exp), env, ng)); + case LAMEXP_TYPE_SEQUENCE: + return prune(analyzeSequence(getLamExp_Sequence(exp), env, ng)); + case LAMEXP_TYPE_MAKEVEC: + cant_happen("encountered make-vec in analyzeExp"); + case LAMEXP_TYPE_CONSTRUCT: + return prune(analyzeConstruct(getLamExp_Construct(exp), env, ng)); + case LAMEXP_TYPE_DECONSTRUCT: + return prune(analyzeDeconstruct(getLamExp_Deconstruct(exp), env, ng)); + case LAMEXP_TYPE_TAG: + return prune(analyzeTag(getLamExp_Tag(exp), env, ng)); + case LAMEXP_TYPE_CONSTANT: + return prune(analyzeConstant(getLamExp_Constant(exp), env, ng)); + case LAMEXP_TYPE_APPLY: + return prune(analyzeApply(getLamExp_Apply(exp), env, ng)); + case LAMEXP_TYPE_IFF: + return prune(analyzeIff(getLamExp_Iff(exp), env, ng)); + case LAMEXP_TYPE_CALLCC: + return prune(analyzeCallCC(getLamExp_CallCC(exp), env, ng)); + case LAMEXP_TYPE_PRINT: { + LamPrint *printer = getLamExp_Print(exp); + TcType *ret = prune(analyzePrint(printer, env, ng)); + return ret; + } + case LAMEXP_TYPE_TYPEOF: + return analyzeTypeOf(exp, env, ng); + case LAMEXP_TYPE_LETREC: + return prune(analyzeLetRec(getLamExp_LetRec(exp), env, ng)); + case LAMEXP_TYPE_TYPEDEFS: + return prune(analyzeTypeDefs(getLamExp_TypeDefs(exp), env, ng)); + case LAMEXP_TYPE_LET: + return prune(analyzeLet(getLamExp_Let(exp), env, ng)); + case LAMEXP_TYPE_LETSTAR: + return prune(analyzeLetStar(getLamExp_LetStar(exp), env, ng)); + case LAMEXP_TYPE_MATCH: + return prune(analyzeMatch(getLamExp_Match(exp), env, ng)); + case LAMEXP_TYPE_COND: + return prune(analyzeCond(getLamExp_Cond(exp), env, ng)); + case LAMEXP_TYPE_AMB: + return prune(analyzeAmb(getLamExp_Amb(exp), env, ng)); + case LAMEXP_TYPE_CHARACTER: + return prune(analyzeCharacter()); + case LAMEXP_TYPE_BACK: + return prune(analyzeBack()); + case LAMEXP_TYPE_ERROR: + return prune(analyzeError()); + case LAMEXP_TYPE_TUPLEINDEX: + return prune(analyzeTupleIndex(getLamExp_TupleIndex(exp), env, ng)); + case LAMEXP_TYPE_MAKETUPLE: + return prune(analyzeMakeTuple(getLamExp_MakeTuple(exp), env, ng)); + case LAMEXP_TYPE_NAMESPACES: + return prune(analyzeNameSpaces(getLamExp_NameSpaces(exp), env, ng)); + case LAMEXP_TYPE_ENV: + return prune(analyzeEnv(env)); + case LAMEXP_TYPE_LOOKUP: + return prune(analyzeLookUp(getLamExp_LookUp(exp), env, ng)); + case LAMEXP_TYPE_CONSTRUCTOR: + return prune( + analyzeVar(CPI(exp), getLamExp_Constructor(exp)->name, env, ng)); + default: + cant_happen("unrecognized type %s", lamExpTypeName(exp->type)); + } +} + +static TcType *makeFunctionType(SymbolList *args, TcEnv *env, TcType *returnType) { // ENTER(makeFunctionType); if (args == NULL) { @@ -316,7 +306,7 @@ static TcType *makeFunctionType(LamVarList *args, TcEnv *env, TcType *next = makeFunctionType(args->next, env, returnType); int save = PROTECT(next); TcType *this = NULL; - if (!getFromTcEnv(env, args->var, &this)) { + if (!getFromTcEnv(env, args->symbol, &this)) { cant_happen("cannot find var in env in makeFunctionType"); } TcType *ret = makeFn(this, next); @@ -331,16 +321,16 @@ static TcType *analyzeLam(LamLam *lam, TcEnv *env, TcNg *ng) { int save = PROTECT(env); ng = newTcNg(ng); PROTECT(ng); - for (LamVarList * args = lam->args; args != NULL; args = args->next) { - TcType *freshType = makeFreshVar(args->var->name); + for (SymbolList *args = lam->args; args != NULL; args = args->next) { + TcType *freshType = makeFreshVar(args->symbol->name); int save2 = PROTECT(freshType); - addToEnv(env, args->var, freshType); + addToEnv(env, args->symbol, freshType); addToNg(ng, freshType); UNPROTECT(save2); } TcType *returnType = analyzeExp(lam->exp, env, ng); PROTECT(returnType); - + // Zero-argument lambda creates a thunk type, not a function type TcType *functionType; if (lam->args == NULL) { @@ -360,17 +350,14 @@ static TcType *analyzeVar(ParserInfo I, HashSymbol *var, TcEnv *env, TcNg *ng) { TcType *res = lookUp(env, var, ng); if (res == NULL) { // ppTcEnv(env); - can_happen("undefined variable %s in %s, line %d", var->name, - I.fileName, I.lineNo); + can_happen(I, "undefined variable %s", var->name); return makeUnknown(var); } // LEAVE(analyzeVar); return res; } -static TcType *analyzeSmallInteger() { - return makeSmallInteger(); -} +static TcType *analyzeSmallInteger() { return makeSmallInteger(); } static TcType *analyzeBigInteger() { // ENTER(analyzeBigInteger); @@ -382,7 +369,7 @@ static TcType *analyzeBigInteger() { static TcType *analyzeBinaryArith(LamExp *exp1, LamExp *exp2, TcEnv *env, TcNg *ng) { // ENTER(analyzeBinaryArith); - (void) analyzeBigIntegerExp(exp1, env, ng); + (void)analyzeBigIntegerExp(exp1, env, ng); TcType *res = analyzeBigIntegerExp(exp2, env, ng); // LEAVE(analyzeBinaryArith); return res; @@ -444,34 +431,97 @@ static TcType *analyzeSpaceship(LamExp *exp1, LamExp *exp2, TcEnv *env, return res; } +static LamExp *lookupComparator(TcType *type, TcEnv *env, ParserInfo I) { + type = prune(type); + + // Only custom types (TYPESIG) can have bespoke comparators + if (type->type != TCTYPE_TYPE_TYPESIG) { + return NULL; + } + + TcTypeSig *typeSig = getTcType_TypeSig(type); + + // Construct the eq$ symbol + HashSymbol *eqName = makePrintName("eq$", typeSig->name->name); + + // Look in the appropriate namespace + TcEnv *nsEnv = getNsEnv(typeSig->ns, env); + + TcType *comparatorType = NULL; + if (!getFromTcEnv(nsEnv, eqName, &comparatorType)) { + // No bespoke comparator found + return NULL; + } + + // Build the expression referencing the comparator + LamExp *exp = newLamExp_Var(I, eqName); + int save = PROTECT(exp); + + // If in different namespace, wrap in LookUp + TcType *currentNs = NULL; + getFromTcEnv(env, nameSpaceSymbol(), ¤tNs); + if (currentNs != NULL && getTcType_NsId(currentNs) != typeSig->ns && + typeSig->ns != NS_GLOBAL) { + LamLookUp *lookUp = newLamLookUp(I, typeSig->ns, NULL, exp); + PROTECT(lookUp); + exp = newLamExp_LookUp(I, lookUp); + PROTECT(exp); + } + + UNPROTECT(save); + return exp; +} + static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng) { // ENTER(analyzePrim); TcType *res = NULL; switch (app->type) { - case LAMPRIMOP_TYPE_ADD: - case LAMPRIMOP_TYPE_SUB: - case LAMPRIMOP_TYPE_MUL: - case LAMPRIMOP_TYPE_DIV: - case LAMPRIMOP_TYPE_MOD: - case LAMPRIMOP_TYPE_POW: - res = analyzeBinaryArith(app->exp1, app->exp2, env, ng); - break; - case LAMPRIMOP_TYPE_EQ: - case LAMPRIMOP_TYPE_NE: - case LAMPRIMOP_TYPE_GT: - case LAMPRIMOP_TYPE_LT: - case LAMPRIMOP_TYPE_GE: - case LAMPRIMOP_TYPE_LE: - res = analyzeComparison(app->exp1, app->exp2, env, ng); - break; - case LAMPRIMOP_TYPE_CMP: - res = analyzeSpaceship(app->exp1, app->exp2, env, ng); - break; - case LAMPRIMOP_TYPE_VEC: - cant_happen("encountered VEC in analyzePrim"); - break; - default: - cant_happen("unrecognised type %d in analyzePrim", app->type); + case LAMPRIMOP_TYPE_ADD: + case LAMPRIMOP_TYPE_SUB: + case LAMPRIMOP_TYPE_MUL: + case LAMPRIMOP_TYPE_DIV: + case LAMPRIMOP_TYPE_MOD: + case LAMPRIMOP_TYPE_POW: + res = analyzeBinaryArith(app->exp1, app->exp2, env, ng); + break; + case LAMPRIMOP_TYPE_EQ: + case LAMPRIMOP_TYPE_NE: + case LAMPRIMOP_TYPE_GT: + case LAMPRIMOP_TYPE_LT: + case LAMPRIMOP_TYPE_GE: + case LAMPRIMOP_TYPE_LE: { + // Analyze the comparison first + res = analyzeComparison(app->exp1, app->exp2, env, ng); + int save = PROTECT(res); + + // For EQ operations, check for bespoke comparator + if (app->type == LAMPRIMOP_TYPE_EQ) { + TcType *type1 = analyzeExp(app->exp1, env, ng); + PROTECT(type1); + LamExp *comparator = lookupComparator(type1, env, CPI(app)); + if (comparator != NULL) { + // Found a bespoke comparator - create replacement + PROTECT(comparator); + LamArgs *args = newLamArgs(CPI(app), app->exp2, NULL); + PROTECT(args); + args = newLamArgs(CPI(app), app->exp1, args); + PROTECT(args); + LamApply *apply = newLamApply(CPI(app), comparator, args); + PROTECT(apply); + app->replacement = newLamExp_Apply(CPI(app), apply); + } + } + UNPROTECT(save); + break; + } + case LAMPRIMOP_TYPE_CMP: + res = analyzeSpaceship(app->exp1, app->exp2, env, ng); + break; + case LAMPRIMOP_TYPE_VEC: + cant_happen("encountered VEC in analyzePrim"); + break; + default: + cant_happen("unrecognised type %d in analyzePrim", app->type); } // LEAVE(analyzePrim); return res; @@ -496,8 +546,7 @@ static LamApply *constructToApply(LamConstruct *construct) { // ENTER(constructToApply); LamExp *constructor = newLamExp_Var(CPI(construct), construct->name); int save = PROTECT(constructor); - LamApply *apply = - newLamApply(CPI(construct), constructor, construct->args); + LamApply *apply = newLamApply(CPI(construct), constructor, construct->args); UNPROTECT(save); // LEAVE(constructToApply); return apply; @@ -549,9 +598,8 @@ static TcType *analyzeDeconstruct(LamDeconstruct *deconstruct, TcEnv *env, int save = PROTECT(constructor); // ppTcType(constructor); eprintf("\n"); if (constructor == NULL) { - can_happen("undefined type deconstructor %s", + can_happen(CPI(deconstruct), "undefined type deconstructor %s", deconstruct->name->name); - REPORT_PARSER_INFO(deconstruct); TcType *res = makeFreshVar(deconstruct->name->name); // LEAVE(analyzeDeconstruct); return res; @@ -645,7 +693,7 @@ static TcType *analyzeNameSpaces(LamNameSpaceArray *nsArray, TcEnv *env, int save = PROTECT(env2); TcNg *ng2 = newTcNg(ng); PROTECT(ng2); - TcType *nsId = newTcType_NsId((int) i); + TcType *nsId = newTcType_NsId((int)i); PROTECT(nsId); addToEnv(env2, nameSpaceSymbol(), nsId); TcType *res = analyzeExp(nsArray->entries[i], env2, ng2); @@ -656,24 +704,23 @@ static TcType *analyzeNameSpaces(LamNameSpaceArray *nsArray, TcEnv *env, return nsType; } -static TcType *analyzeEnv(TcEnv *env) { - return newTcType_Env(env); -} +static TcType *analyzeEnv(TcEnv *env) { return newTcType_Env(env); } static TcType *analyzeTag(LamExp *tagged, TcEnv *env, TcNg *ng) { return analyzeExp(tagged, env, ng); } static TcType *analyzeConstant(LamConstant *constant, TcEnv *env, TcNg *ng) { -// ENTER(analyzeConstant); + // ENTER(analyzeConstant); TcType *constType = lookUp(env, constant->name, ng); if (constType == NULL) { - can_happen("undefined constant %s", constant->name->name); + can_happen(CPI(constant), "undefined constant %s", + constant->name->name); TcType *res = makeFreshVar("err"); -// LEAVE(analyzeConstant); + // LEAVE(analyzeConstant); return res; } -// LEAVE(analyzeConstant); + // LEAVE(analyzeConstant); return constType; } @@ -687,12 +734,9 @@ static LamApply *curryLamApplyHelper(int nArgs, LamExp *function, } LamArgs *singleArg = newLamArgs(CPI(args), args->exp, NULL); int save = PROTECT(singleArg); - LamApply *new = newLamApply(CPI(function), function, singleArg); - PROTECT(new); - LamExp *newFunction = newLamExp_Apply(CPI(new), new); + LamExp *newFunction = makeLamExp_Apply(CPI(function), function, singleArg); PROTECT(newFunction); - LamApply *curried = - curryLamApplyHelper(nArgs - 1, newFunction, args->next); + LamApply *curried = curryLamApplyHelper(nArgs - 1, newFunction, args->next); UNPROTECT(save); return curried; } @@ -703,98 +747,95 @@ static LamApply *curryLamApply(LamApply *apply) { } static TcType *analyzeApply(LamApply *apply, TcEnv *env, TcNg *ng) { -// ENTER(analyzeApply); + // ENTER(analyzeApply); switch (countLamArgs(apply->args)) { - case 0: - { - TcType *fnType = analyzeExp(apply->function, env, ng); - int save = PROTECT(fnType); - fnType = prune(fnType); - - // Check if this is a thunk being forced - if (fnType->type == TCTYPE_TYPE_THUNK) { - // Forcing a thunk extracts its underlying type - TcType *res = getTcType_Thunk(fnType)->type; - UNPROTECT(save); - return res; - } - - // If it's a type variable, constrain it to be a thunk - if (fnType->type == TCTYPE_TYPE_VAR) { - // Create a fresh result type - TcType *resultType = makeFreshVar("thunk_result"); - PROTECT(resultType); - // Create a thunk type wrapping the result - TcType *thunkType = makeThunk(resultType); - PROTECT(thunkType); - // Unify the variable with the thunk type - if (!unify(fnType, thunkType, "zero-arg apply")) { - eprintf("while analyzing zero-arg application of:\n"); - ppLamExp(apply->function); - eprintf("\n"); - REPORT_PARSER_INFO(apply->function); - } - UNPROTECT(save); - return resultType; - } - - // Otherwise, return the function type as-is - // (for zero-arg functions that return function types) - UNPROTECT(save); - // LEAVE(analyzeApply); - return fnType; - } - case 1: - { - // fn :: #a -> #b - TcType *fn = analyzeExp(apply->function, env, ng); - int save = PROTECT(fn); - // arg :: #c - TcType *arg = analyzeExp(apply->args->exp, env, ng); - PROTECT(arg); - // res :: #d - TcType *res = makeFreshVar("apply"); - PROTECT(res); - // functionType :: #c -> #d - TcType *functionType = makeFn(arg, res); - PROTECT(functionType); - // unify(#a -> #b, #c -> #d) - if (!unify(fn, functionType, "apply")) { - eprintf("while analyzing apply "); - ppLamExp(apply->function); - eprintf(" (type: "); - ppTcType(prune(fn)); - eprintf(") to "); - ppLamExp(apply->args->exp); - eprintf(" (type: "); - ppTcType(prune(arg)); - eprintf(")\n"); - REPORT_PARSER_INFO(apply->function); - if (!EQ_PARSER_INFO(apply->function, apply->args)) { - REPORT_PARSER_INFO(apply->args); - } - } - UNPROTECT(save); - // LEAVE(analyzeApply); - res = prune(res); - // #d/#b - return res; + case 0: { + TcType *fnType = analyzeExp(apply->function, env, ng); + int save = PROTECT(fnType); + fnType = prune(fnType); + + // Check if this is a thunk being forced + if (fnType->type == TCTYPE_TYPE_THUNK) { + // Forcing a thunk extracts its underlying type + TcType *res = getTcType_Thunk(fnType)->type; + UNPROTECT(save); + return res; + } + + // If it's a type variable, constrain it to be a thunk + if (fnType->type == TCTYPE_TYPE_VAR) { + // Create a fresh result type + TcType *resultType = makeFreshVar("thunk_result"); + PROTECT(resultType); + // Create a thunk type wrapping the result + TcType *thunkType = makeThunk(resultType); + PROTECT(thunkType); + // Unify the variable with the thunk type + if (!unify(fnType, thunkType, "zero-arg apply")) { + eprintf("while analyzing zero-arg application of:\n"); + ppLamExp(apply->function); + eprintf("\n"); + REPORT_PARSER_INFO(apply->function); } - default: - { - LamApply *curried = curryLamApply(apply); - int save = PROTECT(curried); - TcType *res = analyzeApply(curried, env, ng); - UNPROTECT(save); - // LEAVE(analyzeApply); - return res; + UNPROTECT(save); + return resultType; + } + + // Otherwise, return the function type as-is + // (for zero-arg functions that return function types) + UNPROTECT(save); + // LEAVE(analyzeApply); + return fnType; + } + case 1: { + // fn :: #a -> #b + TcType *fn = analyzeExp(apply->function, env, ng); + int save = PROTECT(fn); + // arg :: #c + TcType *arg = analyzeExp(apply->args->exp, env, ng); + PROTECT(arg); + // res :: #d + TcType *res = makeFreshVar("apply"); + PROTECT(res); + // functionType :: #c -> #d + TcType *functionType = makeFn(arg, res); + PROTECT(functionType); + // unify(#a -> #b, #c -> #d) + if (!unify(fn, functionType, "apply")) { + eprintf("while analyzing apply "); + ppLamExp(apply->function); + eprintf(" (type: "); + ppTcType(prune(fn)); + eprintf(") to "); + ppLamExp(apply->args->exp); + eprintf(" (type: "); + ppTcType(prune(arg)); + eprintf(")\n"); + REPORT_PARSER_INFO(apply->function); + if (!EQ_PARSER_INFO(apply->function, apply->args)) { + REPORT_PARSER_INFO(apply->args); } + } + res = prune(res); + UNPROTECT(save); + // LEAVE(analyzeApply); + // #d/#b + return res; + } + default: { + LamApply *curried = curryLamApply(apply); + int save = PROTECT(curried); + TcType *res = analyzeApply(curried, env, ng); + UNPROTECT(save); + // LEAVE(analyzeApply); + return res; + } } } static TcType *analyzeIff(LamIff *iff, TcEnv *env, TcNg *ng) { -// ENTER(analyzeIff); - (void) analyzeBooleanExp(iff->condition, env, ng); + // ENTER(analyzeIff); + (void)analyzeBooleanExp(iff->condition, env, ng); TcType *consequent = analyzeExp(iff->consequent, env, ng); int save = PROTECT(consequent); TcType *alternative = analyzeExp(iff->alternative, env, ng); @@ -815,12 +856,12 @@ static TcType *analyzeIff(LamIff *iff, TcEnv *env, TcNg *ng) { } } UNPROTECT(save); -// LEAVE(analyzeIff); + // LEAVE(analyzeIff); return consequent; } static TcType *analyzeCallCC(LamExp *called, TcEnv *env, TcNg *ng) { -// 'call/cc' is ((a -> b) -> a) -> a + // 'call/cc' is ((a -> b) -> a) -> a TcType *a = makeFreshVar("callCCA"); int save = PROTECT(a); TcType *b = makeFreshVar("callCCB"); @@ -842,13 +883,13 @@ static TcType *analyzeCallCC(LamExp *called, TcEnv *env, TcNg *ng) { } static TcType *analyzePrint(LamPrint *print, TcEnv *env, TcNg *ng) { -// a -> a, but installs a printer for type a -// ENTER(analyzePrint); + // a -> a, but installs a printer for type a + // ENTER(analyzePrint); TcType *type = analyzeExp(print->exp, env, ng); int save = PROTECT(type); print->printer = compilePrinterForType(CPI(print), type, env); UNPROTECT(save); -// LEAVE(analyzePrint); + // LEAVE(analyzePrint); IFDEBUG(ppTcType(type)); return type; } @@ -864,14 +905,79 @@ static void prepareLetRecEnv(LamBindings *bindings, TcEnv *env) { UNPROTECT(save); } -static void processLetRecBinding(LamBindings *bindings, TcEnv *env, - TcNg *ng) { +static TcEnv *getNsEnv(int index, TcEnv *env) { + if (index == NS_GLOBAL) { + return env; + } + TcType *currentNs = NULL; + getFromTcEnv(env, nameSpaceSymbol(), ¤tNs); +#ifdef SAFETY_CHECKS + if (currentNs == NULL) { + cant_happen("cannot find current nameSpace"); + } +#endif + if (currentNs->val.nsId == index) { + return env; + } + TcType *res = lookUpNsRef(index, env); + return res->val.env; +} + +static bool isEqFunction(HashSymbol *symbol) { + return strncmp(symbol->name, "eq$", 3) == 0; +} + +static HashSymbol *extractTypename(HashSymbol *eqSymbol, const char *prefix) { + size_t prefixLen = strlen(prefix); + size_t nameLen = strlen(eqSymbol->name); + char *typename = NEW_ARRAY(char, nameLen - prefixLen + 1); + strcpy(typename, eqSymbol->name + prefixLen); + HashSymbol *result = newSymbol(typename); + FREE_ARRAY(char, typename, nameLen - prefixLen + 1); + return result; +} + +static TcType *makeEqFunctionType(HashSymbol *typename, TcEnv *env, + ParserInfo I) { + // Get the TcTypeSig for typename + TcTypeSig *typeSig = NULL; + if (!getTypeSigFromTcEnv(env, typename, &typeSig)) { + can_happen(I, "undefined type %s in eq function", typename->name); + return makeFreshVar("eq_error"); + } + + // Build type: typename -> typename -> bool + TcType *typeArg = newTcType_TypeSig(typeSig); + int save = PROTECT(typeArg); + TcType *boolType = makeBoolean(); + PROTECT(boolType); + TcType *secondArg = makeFn(typeArg, boolType); + PROTECT(secondArg); + TcType *result = makeFn(typeArg, secondArg); + UNPROTECT(save); + return result; +} + +static void processLetRecBinding(LamBindings *bindings, TcEnv *env, TcNg *ng) { TcType *existingType = NULL; if (!getFromTcEnv(env, bindings->var, &existingType)) { cant_happen("failed to retrieve fresh var from env in analyzeLetRec"); } int save = PROTECT(existingType); -// Recursive functions need to be statically typed inside their own context: + + // Check if this is an equality comparator function + if (isEqFunction(bindings->var)) { + HashSymbol *typename = extractTypename(bindings->var, "eq$"); + TcType *expectedType = makeEqFunctionType(typename, env, CPI(bindings)); + PROTECT(expectedType); + if (!unify(existingType, expectedType, "eq function type")) { + eprintf("eq function %s must have type %s -> %s -> bool\n", + bindings->var->name, typename->name, typename->name); + REPORT_PARSER_INFO(bindings->val); + } + } + + // Recursive functions need to be statically typed inside their own context: TcNg *ng2 = newTcNg(ng); PROTECT(ng2); addToNg(ng2, existingType); @@ -892,61 +998,166 @@ static void processLetRecBinding(LamBindings *bindings, TcEnv *env, UNPROTECT(save); } -// Helper to capture a snapshot of all binding types as a single string -// Used to detect convergence in iterative type checking -static char *snapshotBindingTypes(LamBindings *bindings, TcEnv *env) { - int capacity = 256; - int size = 0; - char *snapshot = malloc(capacity); +// Forward declarations for normalized type string conversion +static void normalizedTypeToString(TcType *type, SCharArray *buffer, + TcTypeTable *varMap, int *counter); - for (LamBindings * b = bindings; b != NULL; b = b->next) { +static void normalizedTypeToString(TcType *type, SCharArray *buffer, + TcTypeTable *varMap, int *counter) { + if (type == NULL) { + appendStringToSCharArray(buffer, ""); + return; + } + type = prune(type); + switch (type->type) { + case TCTYPE_TYPE_FUNCTION: { + TcFunction *fn = getTcType_Function(type); + if (fn->arg->type == TCTYPE_TYPE_FUNCTION) { + appendStringToSCharArray(buffer, "("); + normalizedTypeToString(fn->arg, buffer, varMap, counter); + appendStringToSCharArray(buffer, ")"); + } else { + normalizedTypeToString(fn->arg, buffer, varMap, counter); + } + appendStringToSCharArray(buffer, " -> "); + normalizedTypeToString(fn->result, buffer, varMap, counter); + break; + } + case TCTYPE_TYPE_PAIR: { + TcPair *pair = getTcType_Pair(type); + appendStringToSCharArray(buffer, "#("); + normalizedTypeToString(pair->first, buffer, varMap, counter); + appendStringToSCharArray(buffer, ", "); + normalizedTypeToString(pair->second, buffer, varMap, counter); + appendStringToSCharArray(buffer, ")"); + break; + } + case TCTYPE_TYPE_THUNK: { + TcThunk *thunk = getTcType_Thunk(type); + appendStringToSCharArray(buffer, "#() -> "); + normalizedTypeToString(thunk->type, buffer, varMap, counter); + break; + } + case TCTYPE_TYPE_VAR: { + TcVar *var = getTcType_Var(type); + // Check if we've seen this variable before + TcType *mapped = NULL; + if (getTcTypeTable(varMap, var->name, &mapped)) { + // Use the previously assigned number + char numBuf[32]; + sprintf(numBuf, "#%d", getTcType_Var(mapped)->id); + appendStringToSCharArray(buffer, numBuf); + } else { + // Assign a new number + int num = (*counter)++; + // Store the mapping (reuse the type but we only care about id) + TcType *placeholder = makeTcType_Var(var->name, num); + int save = PROTECT(placeholder); + setTcTypeTable(varMap, var->name, placeholder); + UNPROTECT(save); + char numBuf[32]; + sprintf(numBuf, "#%d", num); + appendStringToSCharArray(buffer, numBuf); + } + break; + } + case TCTYPE_TYPE_BIGINTEGER: + appendStringToSCharArray(buffer, "number"); + break; + case TCTYPE_TYPE_SMALLINTEGER: + appendStringToSCharArray(buffer, "smallint"); + break; + case TCTYPE_TYPE_CHARACTER: + appendStringToSCharArray(buffer, "char"); + break; + case TCTYPE_TYPE_UNKNOWN: + appendStringToSCharArray(buffer, "unknown:"); + appendStringToSCharArray(buffer, getTcType_Unknown(type)->name); + break; + case TCTYPE_TYPE_TYPESIG: { + TcTypeSig *sig = getTcType_TypeSig(type); + appendStringToSCharArray(buffer, sig->name->name); + if (sig->args != NULL) { + appendStringToSCharArray(buffer, "("); + TcTypeSigArgs *args = sig->args; + while (args != NULL) { + normalizedTypeToString(args->type, buffer, varMap, counter); + if (args->next) { + appendStringToSCharArray(buffer, ", "); + } + args = args->next; + } + appendStringToSCharArray(buffer, ")"); + } + break; + } + case TCTYPE_TYPE_TUPLE: { + TcTypeArray *tuple = getTcType_Tuple(type); + appendStringToSCharArray(buffer, "#("); + for (Index i = 0; i < tuple->size; i++) { + normalizedTypeToString(tuple->entries[i], buffer, varMap, counter); + if (i + 1 < tuple->size) { + appendStringToSCharArray(buffer, ", "); + } + } + appendStringToSCharArray(buffer, ")"); + break; + } + case TCTYPE_TYPE_ENV: + appendStringToSCharArray(buffer, ""); + break; + case TCTYPE_TYPE_OPAQUE: + appendStringToSCharArray(buffer, "opaque:"); + appendStringToSCharArray(buffer, getTcType_Opaque(type)->name); + break; + default: + appendStringToSCharArray(buffer, ""); + } +} + +// Helper to capture a snapshot of all binding types as a single SCharArray +// Used to detect convergence in iterative type checking +// Uses normalized type variable names (#0, #1, ...) for consistent comparison +static SCharArray *snapshotBindingTypes(LamBindings *bindings, TcEnv *env) { + SCharArray *snapshot = newSCharArray(); + int save = PROTECT(snapshot); + // Use a single varMap across all bindings so variables that appear + // in multiple binding types get consistent names + TcTypeTable *varMap = newTcTypeTable(); + PROTECT(varMap); + int counter = 0; + + for (LamBindings *b = bindings; b != NULL; b = b->next) { if (isLambdaBinding(b)) { TcType *type = NULL; if (getFromTcEnv(env, b->var, &type)) { TcType *pruned = prune(type); - char *typeStr = tcTypeToString(pruned); - int nameLen = strlen(b->var->name); - int typeLen = strlen(typeStr); - int needed = size + nameLen + typeLen + 3; // "::" + ";" - - if (needed >= capacity) { - capacity = needed * 2; - char *newSnapshot = malloc(capacity); - memcpy(newSnapshot, snapshot, size); - free(snapshot); - snapshot = newSnapshot; - } - - memcpy(snapshot + size, b->var->name, nameLen); - size += nameLen; - snapshot[size++] = ':'; - snapshot[size++] = ':'; - memcpy(snapshot + size, typeStr, typeLen); - size += typeLen; - snapshot[size++] = ';'; - - free(typeStr); // tcTypeToString uses malloc, so we use free + appendStringToSCharArray(snapshot, b->var->name); + pushSCharArray(snapshot, ':'); + pushSCharArray(snapshot, ':'); + normalizedTypeToString(pruned, snapshot, varMap, &counter); + pushSCharArray(snapshot, ';'); } } } - snapshot[size] = '\0'; + UNPROTECT(save); return snapshot; } static TcType *analyzeLetRec(LamLetRec *letRec, TcEnv *env, TcNg *ng) { -// ENTER(analyzeLetRec); + // ENTER(analyzeLetRec); env = newTcEnv(env); int save = PROTECT(env); ng = newTcNg(ng); PROTECT(ng); -// bind lambdas early - for (LamBindings * bindings = letRec->bindings; bindings != NULL; + // bind lambdas early + for (LamBindings *bindings = letRec->bindings; bindings != NULL; bindings = bindings->next) { if (isLambdaBinding(bindings)) { prepareLetRecEnv(bindings, env); } } - for (LamBindings * bindings = letRec->bindings; bindings != NULL; + for (LamBindings *bindings = letRec->bindings; bindings != NULL; bindings = bindings->next) { DEBUGN("analyzeLetRec %s => ", bindings->var->name); IFDEBUGN(ppLamExp(bindings->val)); @@ -955,50 +1166,45 @@ static TcType *analyzeLetRec(LamLetRec *letRec, TcEnv *env, TcNg *ng) { } processLetRecBinding(bindings, env, ng); } -// Iterate additional passes to allow type constraints to propagate through -// forward references. Stop early when types converge (no changes between passes). -// In practice, most code needs 2-3 passes, complex mutual recursion might need more. + // Iterate additional passes to allow type constraints to propagate through + // forward references. Stop early when types converge (no changes between + // passes). In practice, most code needs 2-3 passes, complex mutual + // recursion might need more. const int MAX_PASSES = 10; int passCount __attribute__((unused)) = 1; - char *prevSnapshot = NULL; + SCharArray *prevSnapshot = NULL; + int save2 = PROTECT(ng); // just reserving a slot on the protection stack for (int pass = 2; pass <= MAX_PASSES && !hadErrors(); pass++) { passCount = pass; - for (LamBindings * bindings = letRec->bindings; - bindings != NULL; bindings = bindings->next) { + for (LamBindings *bindings = letRec->bindings; bindings != NULL; + bindings = bindings->next) { if (isLambdaBinding(bindings)) { processLetRecBinding(bindings, env, ng); } } -// Check if types have converged - char *currentSnapshot = snapshotBindingTypes(letRec->bindings, env); - if (prevSnapshot != NULL - && strcmp(prevSnapshot, currentSnapshot) == 0) { + // Check if types have converged + SCharArray *currentSnapshot = + snapshotBindingTypes(letRec->bindings, env); + int save3 = PROTECT(currentSnapshot); + + if (prevSnapshot != NULL && + eqSCharArray(prevSnapshot, currentSnapshot)) { // No changes this pass - we've converged! DEBUGN("analyzeLetRec converged after %d passes\n", passCount); - free(currentSnapshot); - free(prevSnapshot); - prevSnapshot = NULL; break; } - if (prevSnapshot != NULL) { - // eprintf("snapshot %s != %s\n", prevSnapshot, currentSnapshot); - free(prevSnapshot); - } prevSnapshot = currentSnapshot; - } - - if (prevSnapshot != NULL) { - // eprintf("analyzeLetRec completed after %d passes\n", passCount); - free(prevSnapshot); + REPLACE_PROTECT(save2, prevSnapshot); + UNPROTECT(save3); } TcType *res = analyzeExp(letRec->body, env, ng); UNPROTECT(save); -// LEAVE(analyzeLetRec); + // LEAVE(analyzeLetRec); return res; } @@ -1025,11 +1231,7 @@ TcType *makeTypeSig(HashSymbol *name, TcTypeSigArgs *args, int nsId) { if (strcmp(name->name, "list") == 0 && nsId != -1) { cant_happen("list in ns %d", nsId); } - TcTypeSig *tcTypeSig = newTcTypeSig(name, args, nsId); - int save = PROTECT(tcTypeSig); - TcType *res = newTcType_TypeSig(tcTypeSig); - UNPROTECT(save); - return res; + return makeTcType_TypeSig(name, args, nsId); } static TcType *makeTcTypeSig(LamTypeSig *lamType, TcTypeTable *map, int nsId) { @@ -1054,8 +1256,8 @@ static TcType *makeTuple(int size) { return res; } -static TcType *makeTypeConstructorArg(LamTypeConstructorType * arg, - TcTypeTable * map, TcEnv * env); +static TcType *makeTypeConstructorArg(LamTypeConstructorType *arg, + TcTypeTable *map, TcEnv *env); static TcTypeArray *makeTupleArray(LamTypeConstructorArgs *args, TcTypeTable *map, TcEnv *env) { @@ -1088,47 +1290,45 @@ static TcTypeSigArgs *makeTypeSigArgs(LamTypeConstructorArgs *args, static int findNameSpace(LamLookUpOrSymbol *los, TcEnv *env) { switch (los->type) { - case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: - return getLamLookUpOrSymbol_LookUp(los)->nsId; - case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: - { - // eprintf("looking for %s in ", getLamLookUpOrSymbol_Symbol(los)->name); - // ppTcEnv(env); - TcTypeSig *typeSig; - if (getTypeSigFromTcEnv(env, getLamLookUpOrSymbol_Symbol(los), &typeSig)) { - return typeSig->ns; - } - TcType *ns = NULL; - getFromTcEnv(env, nameSpaceSymbol(), &ns); + case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: + return getLamLookUpOrSymbol_LookUp(los)->nsId; + case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: { + // eprintf("looking for %s in ", + // getLamLookUpOrSymbol_Symbol(los)->name); ppTcEnv(env); + TcTypeSig *typeSig; + if (getTypeSigFromTcEnv(env, getLamLookUpOrSymbol_Symbol(los), + &typeSig)) { + return typeSig->ns; + } + TcType *ns = NULL; + getFromTcEnv(env, nameSpaceSymbol(), &ns); #ifdef SAFETY_CHECKS - if (ns == NULL) { - cant_happen("cannot locate current nameSpace"); - } + if (ns == NULL) { + cant_happen("cannot locate current nameSpace"); + } #endif - return getTcType_NsId(ns); - } - default: - cant_happen("unrecognized %s", - lamLookUpOrSymbolTypeName(los->type)); + return getTcType_NsId(ns); + } + default: + cant_happen("unrecognized %s", lamLookUpOrSymbolTypeName(los->type)); } } static HashSymbol *getUnderlyingFunction(LamLookUpOrSymbol *los) { switch (los->type) { - case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: - return getLamLookUpOrSymbol_LookUp(los)->symbol; - case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: - return getLamLookUpOrSymbol_Symbol(los); - default: - cant_happen("unrecognized %s", - lamLookUpOrSymbolTypeName(los->type)); + case LAMLOOKUPORSYMBOL_TYPE_LOOKUP: + return getLamLookUpOrSymbol_LookUp(los)->symbol; + case LAMLOOKUPORSYMBOL_TYPE_SYMBOL: + return getLamLookUpOrSymbol_Symbol(los); + default: + cant_happen("unrecognized %s", lamLookUpOrSymbolTypeName(los->type)); } } static TcType *makeTypeConstructorApplication(LamTypeFunction *func, TcTypeTable *map, TcEnv *env) { -// this code is building the inner application of a type, i.e. -// list(t) in the context of t -> list(t) -> list(t) + // this code is building the inner application of a type, i.e. + // list(t) in the context of t -> list(t) -> list(t) TcTypeSigArgs *args = makeTypeSigArgs(func->args, map, env); int save = PROTECT(args); int ns = findNameSpace(func->name, env); @@ -1150,31 +1350,31 @@ static TcType *makeTypeConstructorArg(LamTypeConstructorType *arg, TcTypeTable *map, TcEnv *env) { TcType *res = NULL; switch (arg->type) { - case LAMTYPECONSTRUCTORTYPE_TYPE_INTEGER: - res = makeBigInteger(); - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_CHARACTER: - res = makeCharacter(); - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_VAR: - { - if (!getTcTypeTable(map, getLamTypeConstructorType_Var(arg), &res)) { - res = makeVar(getLamTypeConstructorType_Var(arg)); - int save = PROTECT(res); - setTcTypeTable(map, getLamTypeConstructorType_Var(arg), res); - UNPROTECT(save); - } - } - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_FUNCTION: - res = makeTypeConstructorApplication(getLamTypeConstructorType_Function(arg), map, env); - break; - case LAMTYPECONSTRUCTORTYPE_TYPE_TUPLE: - res = makeTupleApplication(getLamTypeConstructorType_Tuple(arg), map, env); - break; - default: - cant_happen("unrecognised type %s in makeTypeConstructorArg", - lamTypeConstructorTypeTypeName(arg->type)); + case LAMTYPECONSTRUCTORTYPE_TYPE_INTEGER: + res = makeBigInteger(); + break; + case LAMTYPECONSTRUCTORTYPE_TYPE_CHARACTER: + res = makeCharacter(); + break; + case LAMTYPECONSTRUCTORTYPE_TYPE_VAR: { + if (!getTcTypeTable(map, getLamTypeConstructorType_Var(arg), &res)) { + res = makeVar(getLamTypeConstructorType_Var(arg)); + int save = PROTECT(res); + setTcTypeTable(map, getLamTypeConstructorType_Var(arg), res); + UNPROTECT(save); + } + } break; + case LAMTYPECONSTRUCTORTYPE_TYPE_FUNCTION: + res = makeTypeConstructorApplication( + getLamTypeConstructorType_Function(arg), map, env); + break; + case LAMTYPECONSTRUCTORTYPE_TYPE_TUPLE: + res = makeTupleApplication(getLamTypeConstructorType_Tuple(arg), map, + env); + break; + default: + cant_happen("unrecognised type %s in makeTypeConstructorArg", + lamTypeConstructorTypeTypeName(arg->type)); } return res; } @@ -1182,8 +1382,8 @@ static TcType *makeTypeConstructorArg(LamTypeConstructorType *arg, static TcType *makeTypeDefConstructor(LamTypeConstructorArgs *args, TcType *result, TcTypeTable *map, TcEnv *env) { -// this code is building the top-level type of a type constructor, i.e. -// pair => t -> list(t) -> list(t) + // this code is building the top-level type of a type constructor, i.e. + // pair => t -> list(t) -> list(t) if (args == NULL) { return result; } @@ -1221,33 +1421,33 @@ static void collectTypeDef(LamTypeDef *lamTypeDef, TcEnv *env) { #endif TcType *tcType = makeTcTypeSig(lamType, map, getTcType_NsId(ns)); PROTECT(tcType); - addTypeSigToEnv(env, getTcType_TypeSig(tcType)->name, getTcType_TypeSig(tcType)); - for (LamTypeConstructorList * list = lamTypeDef->constructors; - list != NULL; list = list->next) { + addTypeSigToEnv(env, getTcType_TypeSig(tcType)->name, + getTcType_TypeSig(tcType)); + for (LamTypeConstructorList *list = lamTypeDef->constructors; list != NULL; + list = list->next) { collectTypeDefConstructor(list->constructor, tcType, env, map); } UNPROTECT(save); } static TcType *analyzeTypeDefs(LamTypeDefs *typeDefs, TcEnv *env, TcNg *ng) { -// ENTER(analyzeTypeDefs); + // ENTER(analyzeTypeDefs); env = newTcEnv(env); int save = PROTECT(env); - for (LamTypeDefList * list = typeDefs->typeDefs; list != NULL; + for (LamTypeDefList *list = typeDefs->typeDefs; list != NULL; list = list->next) { collectTypeDef(list->typeDef, env); } TcType *res = analyzeExp(typeDefs->body, env, ng); UNPROTECT(save); -// LEAVE(analyzeTypeDefs); + // LEAVE(analyzeTypeDefs); return res; } -static void analyzeLetBindings(LamBindings *bindings, TcEnv *env, - TcNg *ng) { +static void analyzeLetBindings(LamBindings *bindings, TcEnv *env, TcNg *ng) { // FIXME: types of let bindings should be inferred in parallel // but we don't currently make use of `let` - for (LamBindings * b = bindings; b != NULL; b = b->next) { + for (LamBindings *b = bindings; b != NULL; b = b->next) { TcType *type = analyzeExp(b->val, env, ng); int save = PROTECT(type); addToEnv(env, b->var, type); @@ -1256,8 +1456,8 @@ static void analyzeLetBindings(LamBindings *bindings, TcEnv *env, } static void analyzeLetStarBindings(LamBindings *bindings, TcEnv *env, - TcNg *ng) { - for (LamBindings * b = bindings; b != NULL; b = b->next) { + TcNg *ng) { + for (LamBindings *b = bindings; b != NULL; b = b->next) { TcType *type = analyzeExp(b->val, env, ng); int save = PROTECT(type); addToEnv(env, b->var, type); @@ -1266,33 +1466,33 @@ static void analyzeLetStarBindings(LamBindings *bindings, TcEnv *env, } static TcType *analyzeLet(LamLet *let, TcEnv *env, TcNg *ng) { -// ENTER(analyzeLet); + // ENTER(analyzeLet); env = newTcEnv(env); int save = PROTECT(env); analyzeLetBindings(let->bindings, env, ng); TcType *res = analyzeExp(let->body, env, ng); UNPROTECT(save); -// LEAVE(analyzeLet); + // LEAVE(analyzeLet); return res; } static TcType *analyzeLetStar(LamLetStar *letStar, TcEnv *env, TcNg *ng) { -// ENTER(analyzeLetStar); -// let* expression is evaluated in the current environment + // ENTER(analyzeLetStar); + // let* expression is evaluated in the current environment env = newTcEnv(env); int save = PROTECT(env); analyzeLetStarBindings(letStar->bindings, env, ng); TcType *res = analyzeExp(letStar->body, env, ng); UNPROTECT(save); -// LEAVE(analyzeLet); + // LEAVE(analyzeLet); return res; } static TcType *analyzeMatchCases(LamMatchList *cases, TcEnv *env, TcNg *ng) { -// ENTER(analyzeMatchCases); + // ENTER(analyzeMatchCases); if (cases == NULL) { TcType *res = makeFreshVar("matchCases"); -// LEAVE(analyzeMatchCases); + // LEAVE(analyzeMatchCases); return res; } TcType *rest = analyzeMatchCases(cases->next, env, ng); @@ -1306,12 +1506,12 @@ static TcType *analyzeMatchCases(LamMatchList *cases, TcEnv *env, TcNg *ng) { REPORT_PARSER_INFO(cases->body); } UNPROTECT(save); -// LEAVE(analyzeMatchCases); + // LEAVE(analyzeMatchCases); return this; } static TcType *analyzeBigIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng) { -// ENTER(analyzeBigIntegerExp); + // ENTER(analyzeBigIntegerExp); TcType *type = analyzeExp(exp, env, ng); int save = PROTECT(type); TcType *integer = makeBigInteger(); @@ -1323,12 +1523,12 @@ static TcType *analyzeBigIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng) { REPORT_PARSER_INFO(exp); } UNPROTECT(save); -// LEAVE(analyzeBigIntegerExp); + // LEAVE(analyzeBigIntegerExp); return integer; } static TcType *analyzeSmallIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng) { -// ENTER(analyzeSmallIntegerExp); + // ENTER(analyzeSmallIntegerExp); TcType *type = analyzeExp(exp, env, ng); int save = PROTECT(type); TcType *integer = makeSmallInteger(); @@ -1340,12 +1540,12 @@ static TcType *analyzeSmallIntegerExp(LamExp *exp, TcEnv *env, TcNg *ng) { REPORT_PARSER_INFO(exp); } UNPROTECT(save); -// LEAVE(analyzeSmallIntegerExp); + // LEAVE(analyzeSmallIntegerExp); return integer; } static TcType *analyzeBooleanExp(LamExp *exp, TcEnv *env, TcNg *ng) { -// ENTER(analyzeBooleanExp); + // ENTER(analyzeBooleanExp); TcType *type = analyzeExp(exp, env, ng); int save = PROTECT(type); TcType *boolean = makeBoolean(); @@ -1357,7 +1557,7 @@ static TcType *analyzeBooleanExp(LamExp *exp, TcEnv *env, TcNg *ng) { REPORT_PARSER_INFO(exp); } UNPROTECT(save); -// LEAVE(analyzeBooleanExp); + // LEAVE(analyzeBooleanExp); return boolean; } @@ -1390,8 +1590,7 @@ static TcType *analyzeIntList(LamIntList *intList, TcEnv *env, TcNg *ng) { } TcType *next = analyzeIntList(intList->next, env, ng); int save = PROTECT(next); - TcType *this = - lookUpConstructorType(intList->name, intList->nsId, env, ng); + TcType *this = lookUpConstructorType(intList->name, intList->nsId, env, ng); PROTECT(this); this = findResultType(this); PROTECT(this); @@ -1404,9 +1603,9 @@ static TcType *analyzeIntList(LamIntList *intList, TcEnv *env, TcNg *ng) { } static TcType *findCaseType(LamMatchList *matchList, TcEnv *env, TcNg *ng) { -// ENTER(findCaseType); + // ENTER(findCaseType); if (matchList == NULL) { -// LEAVE(findCaseType); + // LEAVE(findCaseType); return makeFreshVar("caseType"); } TcType *next = findCaseType(matchList->next, env, ng); @@ -1418,12 +1617,12 @@ static TcType *findCaseType(LamMatchList *matchList, TcEnv *env, TcNg *ng) { REPORT_PARSER_INFO(matchList); } UNPROTECT(save); -// LEAVE(findCaseType); + // LEAVE(findCaseType); return this; } static TcType *analyzeMatch(LamMatch *match, TcEnv *env, TcNg *ng) { -// ENTER(analyzeMatch); + // ENTER(analyzeMatch); TcType *caseType = findCaseType(match->cases, env, ng); int save = PROTECT(caseType); TcType *indexType = analyzeExp(match->index, env, ng); @@ -1433,16 +1632,16 @@ static TcType *analyzeMatch(LamMatch *match, TcEnv *env, TcNg *ng) { REPORT_PARSER_INFO(match); } TcType *res = analyzeMatchCases(match->cases, env, ng); -// LEAVE(analyzeMatch); + // LEAVE(analyzeMatch); UNPROTECT(save); return res; } static TcType *analyzeIntCondCases(LamIntCondCases *cases, TcEnv *env, TcNg *ng) { -// ENTER(analyzeIntCondCases); + // ENTER(analyzeIntCondCases); if (cases == NULL) { -// LEAVE(analyzeIntCondCases); + // LEAVE(analyzeIntCondCases); return makeFreshVar("intCondCases"); } TcType *rest = analyzeIntCondCases(cases->next, env, ng); @@ -1454,15 +1653,15 @@ static TcType *analyzeIntCondCases(LamIntCondCases *cases, TcEnv *env, REPORT_PARSER_INFO(cases->body); } UNPROTECT(save); -// LEAVE(analyzeIntCondCases); + // LEAVE(analyzeIntCondCases); return this; } static TcType *analyzeCharCondCases(LamCharCondCases *cases, TcEnv *env, TcNg *ng) { -// ENTER(analyzeCharCondCases); + // ENTER(analyzeCharCondCases); if (cases == NULL) { -// LEAVE(analyzeCharCondCases); + // LEAVE(analyzeCharCondCases); return makeFreshVar("charCondCases"); } TcType *rest = analyzeCharCondCases(cases->next, env, ng); @@ -1474,57 +1673,51 @@ static TcType *analyzeCharCondCases(LamCharCondCases *cases, TcEnv *env, REPORT_PARSER_INFO(cases->body); } UNPROTECT(save); -// LEAVE(analyzeCharCondCases); + // LEAVE(analyzeCharCondCases); return this; } static TcType *analyzeCond(LamCond *cond, TcEnv *env, TcNg *ng) { -// ENTER(analyzeCond); + // ENTER(analyzeCond); TcType *result = NULL; int save = PROTECT(result); TcType *value = analyzeExp(cond->value, env, ng); PROTECT(value); switch (cond->cases->type) { - case LAMCONDCASES_TYPE_INTEGERS: - { - TcType *integer = makeBigInteger(); - PROTECT(integer); - if (!unify(value, integer, "cond[1]")) { - eprintf("while analyzing integer cond:\n"); - REPORT_PARSER_INFO(cond->value); - ppLamExp(cond->value); - eprintf("\n"); - } - result = - analyzeIntCondCases(getLamCondCases_Integers(cond->cases), env, ng); - } - break; - case LAMCONDCASES_TYPE_CHARACTERS: - { - TcType *character = makeCharacter(); - PROTECT(character); - if (!unify(value, character, "cond[2]")) { - eprintf("while analyzing character cond:\n"); - REPORT_PARSER_INFO(cond->value); - ppLamExp(cond->value); - eprintf("\n"); - } - result = - analyzeCharCondCases(getLamCondCases_Characters(cond->cases), env, - ng); - } - break; - default: - cant_happen("unrecognized type %d in analyzeCond", - cond->cases->type); + case LAMCONDCASES_TYPE_INTEGERS: { + TcType *integer = makeBigInteger(); + PROTECT(integer); + if (!unify(value, integer, "cond[1]")) { + eprintf("while analyzing integer cond:\n"); + REPORT_PARSER_INFO(cond->value); + ppLamExp(cond->value); + eprintf("\n"); + } + result = + analyzeIntCondCases(getLamCondCases_Integers(cond->cases), env, ng); + } break; + case LAMCONDCASES_TYPE_CHARACTERS: { + TcType *character = makeCharacter(); + PROTECT(character); + if (!unify(value, character, "cond[2]")) { + eprintf("while analyzing character cond:\n"); + REPORT_PARSER_INFO(cond->value); + ppLamExp(cond->value); + eprintf("\n"); + } + result = analyzeCharCondCases(getLamCondCases_Characters(cond->cases), + env, ng); + } break; + default: + cant_happen("unrecognized type %d in analyzeCond", cond->cases->type); } UNPROTECT(save); -// LEAVE(analyzeCond); + // LEAVE(analyzeCond); return result; } static TcType *analyzeAmb(LamAmb *amb, TcEnv *env, TcNg *ng) { -// ENTER(analyzeAmb); + // ENTER(analyzeAmb); TcType *left = analyzeExp(amb->left, env, ng); int save = PROTECT(left); TcType *right = analyzeExp(amb->right, env, ng); @@ -1541,28 +1734,28 @@ static TcType *analyzeAmb(LamAmb *amb, TcEnv *env, TcNg *ng) { } } UNPROTECT(save); -// LEAVE(analyzeAmb); + // LEAVE(analyzeAmb); return left; } static TcType *analyzeCharacter() { -// ENTER(analyzeCharacter); + // ENTER(analyzeCharacter); TcType *res = makeCharacter(); -// LEAVE(analyzeCharacter); + // LEAVE(analyzeCharacter); return res; } static TcType *analyzeBack() { -// ENTER(analyzeBack); + // ENTER(analyzeBack); TcType *res = makeFreshVar("back"); -// LEAVE(analyzeBack); + // LEAVE(analyzeBack); return res; } static TcType *analyzeError() { -// ENTER(analyzeError); + // ENTER(analyzeError); TcType *res = makeFreshVar("error"); -// LEAVE(analyzeError); + // LEAVE(analyzeError); return res; } @@ -1604,20 +1797,12 @@ static TcType *freshFunction(TcFunction *fn, TcNg *ng, TcTypeTable *map) { return res; } -static TcType *makePair(TcType *first, TcType *second) { - TcPair *resPair = newTcPair(first, second); - int save = PROTECT(resPair); - TcType *res = newTcType_Pair(resPair); - UNPROTECT(save); - return res; -} - static TcType *freshPair(TcPair *pair, TcNg *ng, TcTypeTable *map) { TcType *first = freshRec(pair->first, ng, map); int save = PROTECT(first); TcType *second = freshRec(pair->second, ng, map); PROTECT(second); - TcType *res = makePair(first, second); + TcType *res = makeTcType_Pair(first, second); UNPROTECT(save); return res; } @@ -1694,71 +1879,67 @@ static TcType *typeGetOrPut(TcTypeTable *map, TcType *typeVar, static TcType *freshRec(TcType *type, TcNg *ng, TcTypeTable *map) { type = prune(type); switch (type->type) { - case TCTYPE_TYPE_FUNCTION: - { - TcType *res = freshFunction(getTcType_Function(type), ng, map); - return res; - } - case TCTYPE_TYPE_PAIR: - { - TcType *res = freshPair(getTcType_Pair(type), ng, map); - return res; - } - case TCTYPE_TYPE_THUNK: - { - TcType *res = freshThunk(getTcType_Thunk(type), ng, map); - return res; - } - case TCTYPE_TYPE_VAR: - if (isGeneric(type, ng)) { - TcType *freshType = makeFreshVar(getTcType_Var(type)->name->name); - int save = PROTECT(freshType); - TcType *res = typeGetOrPut(map, type, freshType); - UNPROTECT(save); - return res; - } - return type; - case TCTYPE_TYPE_SMALLINTEGER: - case TCTYPE_TYPE_BIGINTEGER: - case TCTYPE_TYPE_CHARACTER: - case TCTYPE_TYPE_UNKNOWN: - case TCTYPE_TYPE_OPAQUE: - return type; - case TCTYPE_TYPE_TYPESIG: - { - TcType *res = freshTypeSig(getTcType_TypeSig(type), ng, map); - return res; - } - case TCTYPE_TYPE_TUPLE: - return freshTuple(getTcType_Tuple(type), ng, map); - case TCTYPE_TYPE_ENV: - return type; - default: - cant_happen("unrecognised type %s", tcTypeTypeName(type->type)); + case TCTYPE_TYPE_FUNCTION: { + TcType *res = freshFunction(getTcType_Function(type), ng, map); + return res; + } + case TCTYPE_TYPE_PAIR: { + TcType *res = freshPair(getTcType_Pair(type), ng, map); + return res; + } + case TCTYPE_TYPE_THUNK: { + TcType *res = freshThunk(getTcType_Thunk(type), ng, map); + return res; + } + case TCTYPE_TYPE_VAR: + if (isGeneric(type, ng)) { + TcType *freshType = makeFreshVar(getTcType_Var(type)->name->name); + int save = PROTECT(freshType); + TcType *res = typeGetOrPut(map, type, freshType); + UNPROTECT(save); + return res; + } + return type; + case TCTYPE_TYPE_SMALLINTEGER: + case TCTYPE_TYPE_BIGINTEGER: + case TCTYPE_TYPE_CHARACTER: + case TCTYPE_TYPE_UNKNOWN: + case TCTYPE_TYPE_OPAQUE: + return type; + case TCTYPE_TYPE_TYPESIG: { + TcType *res = freshTypeSig(getTcType_TypeSig(type), ng, map); + return res; + } + case TCTYPE_TYPE_TUPLE: + return freshTuple(getTcType_Tuple(type), ng, map); + case TCTYPE_TYPE_ENV: + return type; + default: + cant_happen("unrecognised type %s", tcTypeTypeName(type->type)); } } static TcType *fresh(TcType *type, TcNg *ng) { -// ENTER(fresh); + // ENTER(fresh); TcTypeTable *map = newTcTypeTable(); int save = PROTECT(map); TcType *res = freshRec(type, ng, map); UNPROTECT(save); -// LEAVE(fresh); + // LEAVE(fresh); return res; } static TcType *lookUp(TcEnv *env, HashSymbol *symbol, TcNg *ng) { -// ENTER(lookUp); + // ENTER(lookUp); TcType *type = NULL; if (getFromTcEnv(env, symbol, &type)) { TcType *res = fresh(type, ng); -// LEAVE(lookUp); + // LEAVE(lookUp); DEBUGN("lookUp %s => ", symbol->name); IFDEBUGN(ppTcType(res)); return res; } -// LEAVE(lookUp); + // LEAVE(lookUp); DEBUG("lookUp %s => NULL", symbol->name); return NULL; } @@ -1783,30 +1964,13 @@ static TcType *makeSpaceship() { } static TcType *makeFn(TcType *arg, TcType *result) { - arg = prune(arg); - result = prune(result); - TcFunction *fn = newTcFunction(arg, result); - int save = PROTECT(fn); - TcType *type = newTcType_Function(fn); - UNPROTECT(save); - return type; + return makeTcType_Function(prune(arg), prune(result)); } -static TcType *makeThunk(TcType *type) { - type = prune(type); - TcThunk *thunk = newTcThunk(type); - int save = PROTECT(thunk); - TcType *res = newTcType_Thunk(thunk); - UNPROTECT(save); - return res; -} +static TcType *makeThunk(TcType *type) { return makeTcType_Thunk(prune(type)); } static TcType *makeVar(HashSymbol *t) { - TcVar *var = newTcVar(t, id_counter++); - int save = PROTECT(var); - TcType *res = newTcType_Var(var); - UNPROTECT(save); - return res; + return makeTcType_Var(t, id_counter++); } TcType *makeFreshVar(char *name __attribute__((unused))) { @@ -1848,17 +2012,17 @@ static void addNegToEnv(TcEnv *env) { } static void addIfToEnv(TcEnv *env) { -// 'if' is bool -> a -> a -> a + // 'if' is bool -> a -> a -> a TcType *boolean = makeBoolean(); int save = PROTECT(boolean); TcType *a = makeFreshVar("if"); - (void) PROTECT(a); + (void)PROTECT(a); TcType *aa = makeFn(a, a); - (void) PROTECT(aa); + (void)PROTECT(aa); TcType *aaa = makeFn(a, aa); - (void) PROTECT(aaa); + (void)PROTECT(aaa); TcType *baaa = makeFn(boolean, aaa); - (void) PROTECT(baaa); + (void)PROTECT(baaa); addToEnv(env, ifSymbol(), baaa); UNPROTECT(save); } @@ -1895,46 +2059,44 @@ static void addBuiltinsToEnv(TcEnv *env, BuiltIns *builtIns) { } static void addNameSpacesToEnv(TcEnv *env) { - TcNameSpaceArray *nameSpaces = newTcNameSpaceArray(); - int save = PROTECT(nameSpaces); - TcType *nsType = newTcType_NameSpaces(nameSpaces); - PROTECT(nsType); + TcType *nsType = makeTcType_NameSpaces(); + int save = PROTECT(nsType); addToEnv(env, nameSpacesSymbol(), nsType); UNPROTECT(save); } static void addHereToEnv(TcEnv *env) { -// 'call/cc' is ((a -> b) -> a) -> a + // 'call/cc' is ((a -> b) -> a) -> a TcType *a = makeFreshVar("hereA"); int save = PROTECT(a); TcType *b = makeFreshVar("hereB"); - (void) PROTECT(b); + (void)PROTECT(b); TcType *ab = makeFn(a, b); - (void) PROTECT(ab); + (void)PROTECT(ab); TcType *aba = makeFn(ab, a); - (void) PROTECT(aba); + (void)PROTECT(aba); TcType *abaa = makeFn(aba, a); - (void) PROTECT(abaa); + (void)PROTECT(abaa); addToEnv(env, hereSymbol(), abaa); UNPROTECT(save); } static void addCmpToEnv(TcEnv *env, HashSymbol *symbol) { -// all binary comparisons are a -> a -> bool + // all binary comparisons are a -> a -> bool TcType *freshType = makeFreshVar(symbol->name); int save = PROTECT(freshType); TcType *boolean = makeBoolean(); - (void) PROTECT(boolean); + (void)PROTECT(boolean); TcType *unOp = makeFn(freshType, boolean); - (void) PROTECT(unOp); + (void)PROTECT(unOp); TcType *binOp = makeFn(freshType, unOp); - (void) PROTECT(binOp); + (void)PROTECT(binOp); addToEnv(env, symbol, binOp); UNPROTECT(save); } static void addFreshVarToEnv(TcEnv *env, HashSymbol *symbol) { -// 'error' and 'back' both have unconstrained types + // 'error' and 'back' both have unconstrained types TcType *freshType = makeFreshVar(symbol->name); int save = PROTECT(freshType); addToEnv(env, symbol, freshType); @@ -1942,17 +2104,17 @@ static void addFreshVarToEnv(TcEnv *env, HashSymbol *symbol) { } static void addBinOpToEnv(TcEnv *env, HashSymbol *symbol, TcType *type) { -// handle all fonctions of the form a -> a -> a + // handle all fonctions of the form a -> a -> a TcType *unOp = makeFn(type, type); int save = PROTECT(unOp); TcType *binOp = makeFn(type, unOp); - (void) PROTECT(binOp); + (void)PROTECT(binOp); addToEnv(env, symbol, binOp); UNPROTECT(save); } static void addIntBinOpToEnv(TcEnv *env, HashSymbol *symbol) { -// int -> int -> int + // int -> int -> int TcType *integer = makeBigInteger(); int save = PROTECT(integer); addBinOpToEnv(env, symbol, integer); @@ -1960,7 +2122,7 @@ static void addIntBinOpToEnv(TcEnv *env, HashSymbol *symbol) { } static void addThenToEnv(TcEnv *env) { -// a -> a -> a + // a -> a -> a TcType *freshType = makeFreshVar(thenSymbol()->name); int save = PROTECT(freshType); addBinOpToEnv(env, thenSymbol(), freshType); @@ -1969,7 +2131,7 @@ static void addThenToEnv(TcEnv *env) { static bool failUnify(TcType *a, TcType *b, char *reason) { // can_happen sets a flag that will prevent later stages - can_happen("\nunification failed [%s]", reason); + can_happen(NULLPI, "\nunification failed [%s]", reason); ppTcType(a); eprintf(" vs "); ppTcType(b); @@ -1979,7 +2141,7 @@ static bool failUnify(TcType *a, TcType *b, char *reason) { static bool failUnifyFunctions(TcFunction *a, TcFunction *b, char *reason) { // can_happen sets a flag that will prevent later stages - can_happen("\nunification failed [%s]", reason); + can_happen(NULLPI, "\nunification failed [%s]", reason); ppTcFunction(a); eprintf(" vs "); ppTcFunction(b); @@ -1988,14 +2150,14 @@ static bool failUnifyFunctions(TcFunction *a, TcFunction *b, char *reason) { } static bool unifyFunctions(TcFunction *a, TcFunction *b) { - bool res = unify(a->arg, b->arg, "functions[arg]") - && unify(a->result, b->result, "functions[result]"); + bool res = unify(a->arg, b->arg, "functions[arg]") && + unify(a->result, b->result, "functions[result]"); return res; } static bool unifyPairs(TcPair *a, TcPair *b) { - bool res = unify(a->first, b->first, "pairs[first]") - && unify(a->second, b->second, "pairs[second]"); + bool res = unify(a->first, b->first, "pairs[first]") && + unify(a->second, b->second, "pairs[second]"); return res; } @@ -2005,7 +2167,7 @@ static bool unifyThunks(TcThunk *a, TcThunk *b) { static bool unifyTuples(TcTypeArray *a, TcTypeArray *b) { if (a->size != b->size) { - can_happen("tuple sizes differ: %d vs %d", a->size, b->size); + can_happen(NULLPI, "tuple sizes differ: %d vs %d", a->size, b->size); return false; } bool unified = true; @@ -2019,14 +2181,14 @@ static bool unifyTuples(TcTypeArray *a, TcTypeArray *b) { static bool unifyOpaque(HashSymbol *a, HashSymbol *b) { if (a != b) { - can_happen("opaque type mismatch %s vs. %s", a->name, b->name); + can_happen(NULLPI, "opaque type mismatch %s vs. %s", a->name, b->name); return false; } return true; } static bool failUnifyTypeSigs(TcTypeSig *a, TcTypeSig *b, char *reason) { - can_happen("\nunification failed [%s]", reason); + can_happen(NULLPI, "\nunification failed [%s]", reason); ppTcTypeSig(a); eprintf(" vs "); ppTcTypeSig(b); @@ -2082,40 +2244,42 @@ static bool _unify(TcType *a, TcType *b) { return failUnify(a, b, "type mismatch"); } switch (a->type) { - case TCTYPE_TYPE_FUNCTION: - return unifyFunctions(getTcType_Function(a), getTcType_Function(b)); - case TCTYPE_TYPE_PAIR: - return unifyPairs(getTcType_Pair(a), getTcType_Pair(b)); - case TCTYPE_TYPE_THUNK: - return unifyThunks(getTcType_Thunk(a), getTcType_Thunk(b)); - case TCTYPE_TYPE_VAR: - cant_happen("encountered var in unify"); - case TCTYPE_TYPE_SMALLINTEGER: - case TCTYPE_TYPE_BIGINTEGER: - case TCTYPE_TYPE_CHARACTER: - return true; - case TCTYPE_TYPE_UNKNOWN: - return false; - case TCTYPE_TYPE_TYPESIG: - return unifyTypeSigs(getTcType_TypeSig(a), getTcType_TypeSig(b)); - case TCTYPE_TYPE_OPAQUE: - return unifyOpaque(getTcType_Opaque(a), getTcType_Opaque(b)); - case TCTYPE_TYPE_TUPLE: - return unifyTuples(getTcType_Tuple(a), getTcType_Tuple(b)); - default: - cant_happen("unrecognised type %s", tcTypeTypeName(a->type)); + case TCTYPE_TYPE_FUNCTION: + return unifyFunctions(getTcType_Function(a), getTcType_Function(b)); + case TCTYPE_TYPE_PAIR: + return unifyPairs(getTcType_Pair(a), getTcType_Pair(b)); + case TCTYPE_TYPE_THUNK: + return unifyThunks(getTcType_Thunk(a), getTcType_Thunk(b)); + case TCTYPE_TYPE_VAR: + cant_happen("encountered var in unify"); + case TCTYPE_TYPE_SMALLINTEGER: + case TCTYPE_TYPE_BIGINTEGER: + case TCTYPE_TYPE_CHARACTER: + return true; + case TCTYPE_TYPE_UNKNOWN: + return false; + case TCTYPE_TYPE_TYPESIG: + return unifyTypeSigs(getTcType_TypeSig(a), getTcType_TypeSig(b)); + case TCTYPE_TYPE_OPAQUE: + return unifyOpaque(getTcType_Opaque(a), getTcType_Opaque(b)); + case TCTYPE_TYPE_TUPLE: + return unifyTuples(getTcType_Tuple(a), getTcType_Tuple(b)); + default: + cant_happen("unrecognised type %s", tcTypeTypeName(a->type)); } } cant_happen("reached end of unify"); } static bool unify(TcType *a, TcType *b, char *trace __attribute__((unused))) { -// *INDENT-OFF* -IFDEBUGN(eprintf("unify(%s) :> ", trace); ppTcType(a); eprintf(" =?= "); ppTcType(b)); -bool res = _unify(a, b); -IFDEBUGN(eprintf("unify(%s) <: ", trace); ppTcType(a); eprintf(" === "); ppTcType(b)); -return res; -// *INDENT-ON* + // *INDENT-OFF* + IFDEBUGN(eprintf("unify(%s) :> ", trace); ppTcType(a); eprintf(" =?= "); + ppTcType(b)); + bool res = _unify(a, b); + IFDEBUGN(eprintf("unify(%s) <: ", trace); ppTcType(a); eprintf(" === "); + ppTcType(b)); + return res; + // *INDENT-ON* } static void pruneTypeSigArgs(TcTypeSigArgs *args) { @@ -2178,24 +2342,24 @@ static bool sameType(TcType *a, TcType *b) { return false; } switch (a->type) { - case TCTYPE_TYPE_FUNCTION: - return sameFunctionType(getTcType_Function(a), getTcType_Function(b)); - case TCTYPE_TYPE_PAIR: - return samePairType(getTcType_Pair(a), getTcType_Pair(b)); - case TCTYPE_TYPE_THUNK: - return sameType(getTcType_Thunk(a)->type, getTcType_Thunk(b)->type); - case TCTYPE_TYPE_VAR: - return getTcType_Var(a)->id == getTcType_Var(b)->id; - case TCTYPE_TYPE_BIGINTEGER: - case TCTYPE_TYPE_SMALLINTEGER: - case TCTYPE_TYPE_CHARACTER: - return true; - case TCTYPE_TYPE_UNKNOWN: - return false; - case TCTYPE_TYPE_TYPESIG: - return sameTypeSig(getTcType_TypeSig(a), getTcType_TypeSig(b)); - default: - cant_happen("unrecognised type %d in sameType", a->type); + case TCTYPE_TYPE_FUNCTION: + return sameFunctionType(getTcType_Function(a), getTcType_Function(b)); + case TCTYPE_TYPE_PAIR: + return samePairType(getTcType_Pair(a), getTcType_Pair(b)); + case TCTYPE_TYPE_THUNK: + return sameType(getTcType_Thunk(a)->type, getTcType_Thunk(b)->type); + case TCTYPE_TYPE_VAR: + return getTcType_Var(a)->id == getTcType_Var(b)->id; + case TCTYPE_TYPE_BIGINTEGER: + case TCTYPE_TYPE_SMALLINTEGER: + case TCTYPE_TYPE_CHARACTER: + return true; + case TCTYPE_TYPE_UNKNOWN: + return false; + case TCTYPE_TYPE_TYPESIG: + return sameTypeSig(getTcType_TypeSig(a), getTcType_TypeSig(b)); + default: + cant_happen("unrecognised type %d in sameType", a->type); } } @@ -2222,8 +2386,7 @@ static bool occursInThunk(TcType *var, TcThunk *thunk) { } static bool occursInTypeSig(TcType *var, TcTypeSig *typeSig) { - for (TcTypeSigArgs * args = typeSig->args; args != NULL; - args = args->next) { + for (TcTypeSigArgs *args = typeSig->args; args != NULL; args = args->next) { if (occursInType(var, args->type)) return true; } @@ -2241,26 +2404,26 @@ static bool occursInTuple(TcType *var, TcTypeArray *tuple) { static bool occursIn(TcType *a, TcType *b) { switch (b->type) { - case TCTYPE_TYPE_FUNCTION: - return occursInFunction(a, getTcType_Function(b)); - case TCTYPE_TYPE_PAIR: - return occursInPair(a, getTcType_Pair(b)); - case TCTYPE_TYPE_THUNK: - return occursInThunk(a, getTcType_Thunk(b)); - case TCTYPE_TYPE_VAR: - cant_happen("occursIn 2nd arg should not be a var"); - case TCTYPE_TYPE_SMALLINTEGER: - case TCTYPE_TYPE_BIGINTEGER: - case TCTYPE_TYPE_CHARACTER: - case TCTYPE_TYPE_UNKNOWN: - case TCTYPE_TYPE_ENV: - case TCTYPE_TYPE_OPAQUE: - return false; - case TCTYPE_TYPE_TYPESIG: - return occursInTypeSig(a, getTcType_TypeSig(b)); - case TCTYPE_TYPE_TUPLE: - return occursInTuple(a, getTcType_Tuple(b)); - default: - cant_happen("unrecognised type %s", tcTypeTypeName(b->type)); + case TCTYPE_TYPE_FUNCTION: + return occursInFunction(a, getTcType_Function(b)); + case TCTYPE_TYPE_PAIR: + return occursInPair(a, getTcType_Pair(b)); + case TCTYPE_TYPE_THUNK: + return occursInThunk(a, getTcType_Thunk(b)); + case TCTYPE_TYPE_VAR: + cant_happen("occursIn 2nd arg should not be a var"); + case TCTYPE_TYPE_SMALLINTEGER: + case TCTYPE_TYPE_BIGINTEGER: + case TCTYPE_TYPE_CHARACTER: + case TCTYPE_TYPE_UNKNOWN: + case TCTYPE_TYPE_ENV: + case TCTYPE_TYPE_OPAQUE: + return false; + case TCTYPE_TYPE_TYPESIG: + return occursInTypeSig(a, getTcType_TypeSig(b)); + case TCTYPE_TYPE_TUPLE: + return occursInTuple(a, getTcType_Tuple(b)); + default: + cant_happen("unrecognised type %s", tcTypeTypeName(b->type)); } } \ No newline at end of file diff --git a/src/tc_helper.c b/src/tc_helper.c index e8413745..cd67c2e8 100644 --- a/src/tc_helper.c +++ b/src/tc_helper.c @@ -16,12 +16,13 @@ * along with this program. If not, see . */ -#include -#include #include "tc_helper.h" -#include "tc_analyze.h" #include "symbol.h" +#include "tc_analyze.h" #include "types.h" +#include "utils.h" +#include +#include void ppTcType(TcType *type) { if (type == NULL) { @@ -29,44 +30,44 @@ void ppTcType(TcType *type) { return; } switch (type->type) { - case TCTYPE_TYPE_FUNCTION: - ppTcFunction(type->val.function); - break; - case TCTYPE_TYPE_PAIR: - ppTcPair(type->val.pair); - break; - case TCTYPE_TYPE_THUNK: - ppTcThunk(type->val.thunk); - break; - case TCTYPE_TYPE_VAR: - ppTcVar(type->val.var); - break; - case TCTYPE_TYPE_BIGINTEGER: - eprintf("number"); - break; - case TCTYPE_TYPE_SMALLINTEGER: - eprintf("smallint"); - break; - case TCTYPE_TYPE_CHARACTER: - eprintf("char"); - break; - case TCTYPE_TYPE_UNKNOWN: - eprintf("unknown:%s", type->val.unknown->name); - break; - case TCTYPE_TYPE_TYPESIG: - ppTcTypeSig(type->val.typeSig); - break; - case TCTYPE_TYPE_TUPLE: - ppTcTuple(type->val.tuple); - break; - case TCTYPE_TYPE_ENV: - eprintf(""); - break; - case TCTYPE_TYPE_OPAQUE: - eprintf("opaque:%s", type->val.opaque->name); - break; - default: - eprintf("unrecognized type %s", tcTypeTypeName(type->type)); + case TCTYPE_TYPE_FUNCTION: + ppTcFunction(type->val.function); + break; + case TCTYPE_TYPE_PAIR: + ppTcPair(type->val.pair); + break; + case TCTYPE_TYPE_THUNK: + ppTcThunk(type->val.thunk); + break; + case TCTYPE_TYPE_VAR: + ppTcVar(type->val.var); + break; + case TCTYPE_TYPE_BIGINTEGER: + eprintf("number"); + break; + case TCTYPE_TYPE_SMALLINTEGER: + eprintf("smallint"); + break; + case TCTYPE_TYPE_CHARACTER: + eprintf("char"); + break; + case TCTYPE_TYPE_UNKNOWN: + eprintf("unknown:%s", type->val.unknown->name); + break; + case TCTYPE_TYPE_TYPESIG: + ppTcTypeSig(type->val.typeSig); + break; + case TCTYPE_TYPE_TUPLE: + ppTcTuple(type->val.tuple); + break; + case TCTYPE_TYPE_ENV: + eprintf(""); + break; + case TCTYPE_TYPE_OPAQUE: + eprintf("opaque:%s", type->val.opaque->name); + break; + default: + eprintf("unrecognized type %s", tcTypeTypeName(type->type)); } } @@ -133,6 +134,7 @@ void ppTcTypeSig(TcTypeSig *typeSig) { } } +// Bespoke implementation. bool eqTcVar(struct TcVar *a, struct TcVar *b, HashTable *map) { if (a == b) return true; @@ -157,14 +159,13 @@ bool eqTcVar(struct TcVar *a, struct TcVar *b, HashTable *map) { return true; } -static inline void pad(int depth) { - eprintf("%*s", depth * 2, ""); -} +static inline void pad(int depth) { eprintf("%*s", depth * 2, ""); } static void _ppTcEnv(TcEnv *env, int depth, bool done_nameSpaces); static void _ppTcNameSpaces(TcNameSpaceArray *nameSpaces, int depth) { - if (nameSpaces == NULL) return; + if (nameSpaces == NULL) + return; for (Index i = 0; i < nameSpaces->size; i++) { pad(depth); eprintf("[%u]:\n", i); @@ -190,12 +191,15 @@ static void _ppTcEnv(TcEnv *env, int depth, bool done_nameSpaces) { while ((name = iterateTcTypeTable(env->table, &i, &value)) != NULL) { pad(depth); if (value->type == TCTYPE_TYPE_NSID) { - eprintf(" %s => %s [%d]\n", name->name, tcTypeTypeName(value->type), value->val.nsId); + eprintf(" %s => %s [%d]\n", name->name, + tcTypeTypeName(value->type), value->val.nsId); } else if (value->type == TCTYPE_TYPE_NAMESPACES) { if (done_nameSpaces) { - eprintf(" %s => %s\n", name->name, tcTypeTypeName(value->type)); + eprintf(" %s => %s\n", name->name, + tcTypeTypeName(value->type)); } else { - eprintf(" %s => %s [\n", name->name, tcTypeTypeName(value->type)); + eprintf(" %s => %s [\n", name->name, + tcTypeTypeName(value->type)); _ppTcNameSpaces(value->val.nameSpaces, depth + 1); pad(depth); eprintf(" ]\n"); @@ -209,158 +213,139 @@ static void _ppTcEnv(TcEnv *env, int depth, bool done_nameSpaces) { eprintf("}\n"); } -void ppTcEnv(TcEnv *env) { - _ppTcEnv(env, 0, false); -} - -// Helper function to append to a dynamically growing buffer -static void appendToBuffer(char **buffer, int *size, int *capacity, const char *str) { - int len = strlen(str); - while (*size + len >= *capacity) { - *capacity *= 2; - *buffer = realloc(*buffer, *capacity); - if (buffer == NULL) { - eprintf("Out of memory in appendToBuffer\n"); - exit(1); - } - } - strcpy(*buffer + *size, str); - *size += len; -} +void ppTcEnv(TcEnv *env) { _ppTcEnv(env, 0, false); } // Forward declarations for string conversion -static void tcTypeToStringHelper(TcType *type, char **buffer, int *size, int *capacity); -static void tcFunctionToString(TcFunction *function, char **buffer, int *size, int *capacity); -static void tcPairToString(TcPair *pair, char **buffer, int *size, int *capacity); -static void tcThunkToString(TcThunk *thunk, char **buffer, int *size, int *capacity); -static void tcVarToString(TcVar *var, char **buffer, int *size, int *capacity); -static void tcTupleToString(TcTypeArray *tuple, char **buffer, int *size, int *capacity); -static void tcTypeSigToString(TcTypeSig *typeSig, char **buffer, int *size, int *capacity); -static void tcTypeSigArgsToString(TcTypeSigArgs *args, char **buffer, int *size, int *capacity); +static void tcTypeToStringHelper(TcType *type, SCharArray *buffer); +static void tcFunctionToString(TcFunction *function, SCharArray *buffer); +static void tcPairToString(TcPair *pair, SCharArray *buffer); +static void tcThunkToString(TcThunk *thunk, SCharArray *buffer); +static void tcVarToString(TcVar *var, SCharArray *buffer); +static void tcTupleToString(TcTypeArray *tuple, SCharArray *buffer); +static void tcTypeSigToString(TcTypeSig *typeSig, SCharArray *buffer); +static void tcTypeSigArgsToString(TcTypeSigArgs *args, SCharArray *buffer); -static void tcTypeToStringHelper(TcType *type, char **buffer, int *size, int *capacity) { +static void tcTypeToStringHelper(TcType *type, SCharArray *buffer) { if (type == NULL) { - appendToBuffer(buffer, size, capacity, ""); + appendStringToSCharArray(buffer, ""); return; } switch (type->type) { - case TCTYPE_TYPE_FUNCTION: - tcFunctionToString(type->val.function, buffer, size, capacity); - break; - case TCTYPE_TYPE_PAIR: - tcPairToString(type->val.pair, buffer, size, capacity); - break; - case TCTYPE_TYPE_THUNK: - tcThunkToString(type->val.thunk, buffer, size, capacity); - break; - case TCTYPE_TYPE_VAR: - tcVarToString(type->val.var, buffer, size, capacity); - break; - case TCTYPE_TYPE_BIGINTEGER: - appendToBuffer(buffer, size, capacity, "number"); - break; - case TCTYPE_TYPE_SMALLINTEGER: - appendToBuffer(buffer, size, capacity, "smallint"); - break; - case TCTYPE_TYPE_CHARACTER: - appendToBuffer(buffer, size, capacity, "char"); - break; - case TCTYPE_TYPE_UNKNOWN: - appendToBuffer(buffer, size, capacity, "unknown:"); - appendToBuffer(buffer, size, capacity, type->val.unknown->name); - break; - case TCTYPE_TYPE_TYPESIG: - tcTypeSigToString(type->val.typeSig, buffer, size, capacity); - break; - case TCTYPE_TYPE_TUPLE: - tcTupleToString(type->val.tuple, buffer, size, capacity); - break; - case TCTYPE_TYPE_ENV: - appendToBuffer(buffer, size, capacity, ""); - break; - case TCTYPE_TYPE_OPAQUE: - appendToBuffer(buffer, size, capacity, "opaque:"); - appendToBuffer(buffer, size, capacity, type->val.opaque->name); - break; - default: - appendToBuffer(buffer, size, capacity, ""); + case TCTYPE_TYPE_FUNCTION: + tcFunctionToString(type->val.function, buffer); + break; + case TCTYPE_TYPE_PAIR: + tcPairToString(type->val.pair, buffer); + break; + case TCTYPE_TYPE_THUNK: + tcThunkToString(type->val.thunk, buffer); + break; + case TCTYPE_TYPE_VAR: + tcVarToString(type->val.var, buffer); + break; + case TCTYPE_TYPE_BIGINTEGER: + appendStringToSCharArray(buffer, "number"); + break; + case TCTYPE_TYPE_SMALLINTEGER: + appendStringToSCharArray(buffer, "smallint"); + break; + case TCTYPE_TYPE_CHARACTER: + appendStringToSCharArray(buffer, "char"); + break; + case TCTYPE_TYPE_UNKNOWN: + appendStringToSCharArray(buffer, "unknown:"); + appendStringToSCharArray(buffer, type->val.unknown->name); + break; + case TCTYPE_TYPE_TYPESIG: + tcTypeSigToString(type->val.typeSig, buffer); + break; + case TCTYPE_TYPE_TUPLE: + tcTupleToString(type->val.tuple, buffer); + break; + case TCTYPE_TYPE_ENV: + appendStringToSCharArray(buffer, ""); + break; + case TCTYPE_TYPE_OPAQUE: + appendStringToSCharArray(buffer, "opaque:"); + appendStringToSCharArray(buffer, type->val.opaque->name); + break; + default: + appendStringToSCharArray(buffer, ""); } } -static void tcFunctionToString(TcFunction *function, char **buffer, int *size, int *capacity) { +static void tcFunctionToString(TcFunction *function, SCharArray *buffer) { if (function->arg->type == TCTYPE_TYPE_FUNCTION) { - appendToBuffer(buffer, size, capacity, "("); - tcTypeToStringHelper(function->arg, buffer, size, capacity); - appendToBuffer(buffer, size, capacity, ")"); + appendStringToSCharArray(buffer, "("); + tcTypeToStringHelper(function->arg, buffer); + appendStringToSCharArray(buffer, ")"); } else { - tcTypeToStringHelper(function->arg, buffer, size, capacity); + tcTypeToStringHelper(function->arg, buffer); } - appendToBuffer(buffer, size, capacity, " -> "); - tcTypeToStringHelper(function->result, buffer, size, capacity); + appendStringToSCharArray(buffer, " -> "); + tcTypeToStringHelper(function->result, buffer); } -static void tcPairToString(TcPair *pair, char **buffer, int *size, int *capacity) { - appendToBuffer(buffer, size, capacity, "#("); - tcTypeToStringHelper(pair->first, buffer, size, capacity); - appendToBuffer(buffer, size, capacity, ", "); - tcTypeToStringHelper(pair->second, buffer, size, capacity); - appendToBuffer(buffer, size, capacity, ")"); +static void tcPairToString(TcPair *pair, SCharArray *buffer) { + appendStringToSCharArray(buffer, "#("); + tcTypeToStringHelper(pair->first, buffer); + appendStringToSCharArray(buffer, ", "); + tcTypeToStringHelper(pair->second, buffer); + appendStringToSCharArray(buffer, ")"); } -static void tcThunkToString(TcThunk *thunk, char **buffer, int *size, int *capacity) { - appendToBuffer(buffer, size, capacity, "#() -> "); - tcTypeToStringHelper(thunk->type, buffer, size, capacity); +static void tcThunkToString(TcThunk *thunk, SCharArray *buffer) { + appendStringToSCharArray(buffer, "#() -> "); + tcTypeToStringHelper(thunk->type, buffer); } -static void tcVarToString(TcVar *var, char **buffer, int *size, int *capacity) { +static void tcVarToString(TcVar *var, SCharArray *buffer) { if (var->instance != NULL) { // If the var is bound to a concrete type, show that instead - tcTypeToStringHelper(var->instance, buffer, size, capacity); + tcTypeToStringHelper(var->instance, buffer); } else { // Show as a type variable - appendToBuffer(buffer, size, capacity, "#"); - appendToBuffer(buffer, size, capacity, var->name->name); + appendStringToSCharArray(buffer, "#"); + appendStringToSCharArray(buffer, var->name->name); } } -static void tcTupleToString(TcTypeArray *tuple, char **buffer, int *size, int *capacity) { - appendToBuffer(buffer, size, capacity, "#("); +static void tcTupleToString(TcTypeArray *tuple, SCharArray *buffer) { + appendStringToSCharArray(buffer, "#("); for (Index i = 0; i < tuple->size; i++) { - tcTypeToStringHelper(tuple->entries[i], buffer, size, capacity); + tcTypeToStringHelper(tuple->entries[i], buffer); if (i + 1 < tuple->size) { - appendToBuffer(buffer, size, capacity, ", "); + appendStringToSCharArray(buffer, ", "); } } - appendToBuffer(buffer, size, capacity, ")"); + appendStringToSCharArray(buffer, ")"); } -static void tcTypeSigArgsToString(TcTypeSigArgs *args, char **buffer, int *size, int *capacity) { +static void tcTypeSigArgsToString(TcTypeSigArgs *args, SCharArray *buffer) { while (args != NULL) { - tcTypeToStringHelper(args->type, buffer, size, capacity); + tcTypeToStringHelper(args->type, buffer); if (args->next) { - appendToBuffer(buffer, size, capacity, ", "); + appendStringToSCharArray(buffer, ", "); } args = args->next; } } -static void tcTypeSigToString(TcTypeSig *typeSig, char **buffer, int *size, int *capacity) { - appendToBuffer(buffer, size, capacity, typeSig->name->name); +static void tcTypeSigToString(TcTypeSig *typeSig, SCharArray *buffer) { + appendStringToSCharArray(buffer, typeSig->name->name); if (typeSig->args != NULL) { - appendToBuffer(buffer, size, capacity, "("); - tcTypeSigArgsToString(typeSig->args, buffer, size, capacity); - appendToBuffer(buffer, size, capacity, ")"); + appendStringToSCharArray(buffer, "("); + tcTypeSigArgsToString(typeSig->args, buffer); + appendStringToSCharArray(buffer, ")"); } } -// Public function to convert TcType to string -char *tcTypeToString(TcType *type) { - int capacity = 256; - int size = 0; - char *buffer = malloc(capacity); - buffer[0] = '\0'; - - tcTypeToStringHelper(type, &buffer, &size, &capacity); - - return buffer; +// Public function to convert TcType to SCharArray +SCharArray *tcTypeToSCharArray(TcType *type) { + + SCharArray *buffer = newSCharArray(); + int save = PROTECT(buffer); + tcTypeToStringHelper(type, buffer); + UNPROTECT(save); + return buffer; // Caller will null-terminate if needed } diff --git a/src/tc_helper.h b/src/tc_helper.h index de27827b..ff05f2f5 100644 --- a/src/tc_helper.h +++ b/src/tc_helper.h @@ -1,5 +1,5 @@ #ifndef cekf_tc_helper_h -# define cekf_tc_helper_h +#define cekf_tc_helper_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,8 +18,9 @@ * along with this program. If not, see . */ -# include "ast_helper.h" -# include "tc.h" +#include "ast_helper.h" +#include "tc.h" +#include "utils.h" void ppTcType(TcType *type); void ppTcFunction(TcFunction *function); @@ -30,6 +31,7 @@ void ppTcTypeSig(TcTypeSig *typeSig); void ppTcTuple(TcTypeArray *tuple); void ppTcEnv(TcEnv *env); bool getFromTcEnv(TcEnv *env, HashSymbol *symbol, TcType **type); -char *tcTypeToString(TcType *type); +SCharArray *tcTypeToSCharArray(TcType *type); +void appendStringToSCharArray(SCharArray *buffer, char *str); #endif diff --git a/src/tpmc.yaml b/src/tpmc.yaml index d3ef4258..c5b0a19b 100644 --- a/src/tpmc.yaml +++ b/src/tpmc.yaml @@ -21,9 +21,11 @@ config: description: Term Pattern Matching Compiler types includes: - lambda.h + - utils.h limited_includes: - lambda_pp.h - bigint.h + - utils_debug.h structs: TpmcMatchRules: @@ -35,7 +37,7 @@ structs: and the first matching rule determines the action to be taken. data: rules: TpmcMatchRuleArray - rootVariables: TpmcVariableArray + rootVariables: SymbolArray TpmcMatchRule: meta: @@ -55,6 +57,7 @@ structs: data: previous: TpmcPattern current: TpmcPattern + requiredPath: HashSymbol=NULL TpmcAssignmentPattern: meta: @@ -119,7 +122,7 @@ structs: data: refCount: int=0 stamp: int - freeVariables: TpmcVariableTable=NULL + freeVariables: SymbolSet=NULL state: TpmcStateValue TpmcArc: @@ -131,7 +134,7 @@ structs: data: state: TpmcState test: TpmcPattern - freeVariables: TpmcVariableTable + freeVariables: SymbolSet TpmcArcList: meta: @@ -154,22 +157,6 @@ structs: next: TpmcIntList hashes: - TpmcVariableTable: - meta: - brief: TPMC variable table - description: >- - A set of variables. - data: {} - - TpmcSubstitutionTable: - meta: - brief: TPMC substitution table - description: >- - A set of substitutions, mapping variables to their corresponding - patterns or values. - data: - entries: HashSymbol - TpmcPatternTable: meta: brief: TPMC pattern table @@ -233,15 +220,6 @@ arrays: data: entries: TpmcMatchRule - TpmcVariableArray: - meta: - brief: TPMC variable array - description: >- - An array of variables used in the term pattern matching process. - Variables can be used in patterns to match against terms. - data: - entries: HashSymbol - TpmcPatternArray: meta: brief: TPMC pattern array @@ -272,15 +250,6 @@ arrays: data: entries: TpmcArc - TpmcIntArray: - meta: - brief: TPMC integer array - description: >- - An array of integers used in the term pattern matching process. - This can be used for various purposes, such as storing indices or counts. - data: - entries: int - TpmcMatrix: meta: brief: TPMC matrix @@ -294,19 +263,5 @@ arrays: primitives: !include primitives.yaml external: - LamExp: - data: - cname: "LamExp *" - printFn: ppLamExpD - markFn: markLamExp - copyFn: copyLamExp - valued: true - - LamTypeConstructorInfo: - data: - cname: "LamTypeConstructorInfo *" - printFn: printLamTypeConstructorInfo - markFn: markLamTypeConstructorInfo - copyFn: copyLamTypeConstructorInfo - valued: true - +- !include lambda.yaml +- !include utils.yaml \ No newline at end of file diff --git a/src/tpmc_logic.c b/src/tpmc_logic.c index c789a3a3..56fe9488 100644 --- a/src/tpmc_logic.c +++ b/src/tpmc_logic.c @@ -18,26 +18,27 @@ * Term Pattern Matching Compiler logic */ -#include -#include -#include "common.h" #include "tpmc_logic.h" -#include "tpmc_translate.h" +#include "ast_helper.h" +#include "common.h" +#include "lambda_pp.h" +#include "lambda_substitution.h" +#include "memory.h" +#include "symbol.h" #include "tpmc.h" #include "tpmc_debug.h" #include "tpmc_match.h" -#include "ast_helper.h" -#include "symbol.h" -#include "memory.h" -#include "lambda_substitution.h" -#include "lambda_pp.h" #include "tpmc_mermaid.h" #include "tpmc_pp.h" +#include "tpmc_translate.h" #include "types.h" +#include +#include +#include #ifdef DEBUG_TPMC_LOGIC -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif static TpmcPattern *convertPattern(AstFarg *arg, LamContext *env); @@ -45,16 +46,16 @@ static TpmcPattern *convertPattern(AstFarg *arg, LamContext *env); /** * @brief Creates an array of root variables, one per top-level argument. * @param nArgs The number of arguments. - * @return A new TpmcVariableArray representing the root variables. + * @return A new SymbolArray representing the root variables. */ -static TpmcVariableArray *createRootVariables(int nArgs) { +static SymbolArray *createRootVariables(int nArgs) { ENTER(createRootVariables); - TpmcVariableArray *rootVariables = newTpmcVariableArray(); + SymbolArray *rootVariables = newSymbolArray(); int save = PROTECT(rootVariables); for (int i = 0; i < nArgs; i++) { HashSymbol *s = genSym("p$"); IFDEBUG(eprintf("%s", s->name)); - pushTpmcVariableArray(rootVariables, s); + pushSymbolArray(rootVariables, s); } UNPROTECT(save); LEAVE(createRootVariables); @@ -83,8 +84,10 @@ static TpmcPattern *makeWildCardPattern() { return pattern; } -static TpmcPattern *makeLookUpPattern(AstLookUpSymbol *lookUp, LamContext *env) { - LamTypeConstructorInfo *info = lookUpScopedAstSymbolInLamContext(env, lookUp); +static TpmcPattern *makeLookUpPattern(AstLookUpSymbol *lookUp, + LamContext *env) { + LamTypeConstructorInfo *info = + lookUpScopedAstSymbolInLamContext(env, lookUp); if (info == NULL) { cant_happen("makeLookUpPattern() passed invalid constructor"); } @@ -93,8 +96,7 @@ static TpmcPattern *makeLookUpPattern(AstLookUpSymbol *lookUp, LamContext *env) TpmcConstructorPattern *constructor = newTpmcConstructorPattern(lookUp->symbol, lookUp->nsId, info, args); PROTECT(constructor); - TpmcPatternValue *val = - newTpmcPatternValue_Constructor(constructor); + TpmcPatternValue *val = newTpmcPatternValue_Constructor(constructor); PROTECT(val); TpmcPattern *pattern = newTpmcPattern(val); UNPROTECT(save); @@ -137,37 +139,41 @@ static TpmcPattern *makeAssignmentPattern(AstNamedArg *named, LamContext *env) { return pattern; } -static void getSymbolAndNameSpace(AstLookUpOrSymbol *los, LamContext *env, HashSymbol **name, int *nameSpace) { +static void getSymbolAndNameSpace(AstLookUpOrSymbol *los, LamContext *env, + HashSymbol **name, int *nameSpace) { switch (los->type) { - case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: - *name = los->val.lookUp->symbol; - *nameSpace = los->val.lookUp->nsId; - break; - case AST_LOOKUPORSYMBOL_TYPE_SYMBOL:{ - *nameSpace = lookUpCurrentNameSpaceInLamContext(env); - *name = los->val.symbol; - } - break; - default: - cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); + case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: + *name = los->val.lookUp->symbol; + *nameSpace = los->val.lookUp->nsId; + break; + case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: { + *nameSpace = lookUpCurrentNameSpaceInLamContext(env); + *name = los->val.symbol; + } break; + default: + cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); } } static char *getLookUpName(AstLookUpOrSymbol *los) { switch (los->type) { - case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: - return los->val.lookUp->symbol->name; - case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: - return los->val.symbol->name; - default: - cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); + case AST_LOOKUPORSYMBOL_TYPE_LOOKUP: + return los->val.lookUp->symbol->name; + case AST_LOOKUPORSYMBOL_TYPE_SYMBOL: + return los->val.symbol->name; + default: + cant_happen("unrecognized %s", astLookUpOrSymbolTypeName(los->type)); } } static TpmcPattern *makeConstructorPattern(AstUnpack *unpack, LamContext *env) { - LamTypeConstructorInfo *info = lookUpScopedAstConstructorInLamContext(env, unpack->symbol); + LamTypeConstructorInfo *info = + lookUpScopedAstConstructorInLamContext(env, unpack->symbol); if (info == NULL) { - cant_happen("makeConstructorPattern() passed invalid constructor: '%s'", getLookUpName(unpack->symbol)); + cant_happen("makeConstructorPattern() passed invalid constructor: '%s' " + "in %s line %d", + getLookUpName(unpack->symbol), CPI(unpack).fileName, + CPI(unpack).lineNo); } TpmcPatternArray *patterns = convertArgList(unpack->argList, env); int save = PROTECT(patterns); @@ -212,25 +218,25 @@ static TpmcPattern *makeCharacterPattern(Character character) { static TpmcPattern *convertPattern(AstFarg *arg, LamContext *env) { switch (arg->type) { - case AST_FARG_TYPE_WILDCARD: - return makeWildCardPattern(); - case AST_FARG_TYPE_SYMBOL: - return makeVarPattern(arg->val.symbol, env); - case AST_FARG_TYPE_NAMED: - return makeAssignmentPattern(arg->val.named, env); - case AST_FARG_TYPE_UNPACK: - return makeConstructorPattern(arg->val.unpack, env); - case AST_FARG_TYPE_TUPLE: - return makeTuplePattern(arg->val.tuple, env); - case AST_FARG_TYPE_NUMBER: - return makeMaybeBigIntegerPattern(arg->val.number); - case AST_FARG_TYPE_CHARACTER: - return makeCharacterPattern(arg->val.character); - case AST_FARG_TYPE_LOOKUP: - return makeLookUpPattern(arg->val.lookUp, env); - default: - cant_happen("unrecognized arg type %s in convertPattern", - astFargTypeName(arg->type)); + case AST_FARG_TYPE_WILDCARD: + return makeWildCardPattern(); + case AST_FARG_TYPE_SYMBOL: + return makeVarPattern(arg->val.symbol, env); + case AST_FARG_TYPE_NAMED: + return makeAssignmentPattern(arg->val.named, env); + case AST_FARG_TYPE_UNPACK: + return makeConstructorPattern(arg->val.unpack, env); + case AST_FARG_TYPE_TUPLE: + return makeTuplePattern(arg->val.tuple, env); + case AST_FARG_TYPE_NUMBER: + return makeMaybeBigIntegerPattern(arg->val.number); + case AST_FARG_TYPE_CHARACTER: + return makeCharacterPattern(arg->val.character); + case AST_FARG_TYPE_LOOKUP: + return makeLookUpPattern(arg->val.lookUp, env); + default: + cant_happen("unrecognized arg type %s in convertPattern", + astFargTypeName(arg->type)); } } @@ -241,14 +247,11 @@ static TpmcPattern *convertPattern(AstFarg *arg, LamContext *env) { * @param env The lambda context. * @return A new match rule representing the converted function. */ -static TpmcMatchRule *convertSingle(AstFargList *argList, - LamExp *body, +static TpmcMatchRule *convertSingle(AstFargList *argList, LamExp *body, LamContext *env) { TpmcPatternArray *patterns = convertArgList(argList, env); int save = PROTECT(patterns); - TpmcFinalState *finalState = newTpmcFinalState(body); - PROTECT(finalState); - TpmcStateValue *stateVal = newTpmcStateValue_Final(finalState); + TpmcStateValue *stateVal = makeTpmcStateValue_Final(body); PROTECT(stateVal); TpmcState *state = tpmcMakeState(stateVal); PROTECT(state); @@ -267,10 +270,8 @@ static TpmcMatchRule *convertSingle(AstFargList *argList, * @param env The lambda context. * @return A new array of match rules representing the converted function. */ -static TpmcMatchRuleArray *convertComposite(int nbodies, - AstFargList **argLists, - LamExp **bodies, - LamContext *env) { +static TpmcMatchRuleArray *convertComposite(int nbodies, AstFargList **argLists, + LamExp **bodies, LamContext *env) { TpmcMatchRuleArray *result = newTpmcMatchRuleArray(); int save = PROTECT(result); for (int i = 0; i < nbodies; i++) { @@ -288,86 +289,111 @@ static TpmcState *makeErrorState() { int save = PROTECT(stateVal); TpmcState *state = tpmcMakeState(stateVal); PROTECT(state); - state->freeVariables = newTpmcVariableTable(); + state->freeVariables = newSymbolSet(); UNPROTECT(save); return state; } -static void renamePattern(TpmcPattern *pattern, HashSymbol *variable); +static void renamePattern(TpmcPattern *pattern, HashSymbol *variable, + ParserInfo I); static void renameComparisonPattern(TpmcComparisonPattern *pattern, - HashSymbol *path) { - renamePattern(pattern->current, path); // previous will already have been named + HashSymbol *path, ParserInfo I) { +#ifdef DEBUG_TPMC_MATCH + eprintf("renameComparisonPattern ENTER: path=%s, previous=%p, current=%p\n", + path ? path->name : "NULL", (void *)pattern->previous, + (void *)pattern->current); + if (pattern->previous) { + eprintf( + " previous->path BEFORE=%s, type=%d\n", + pattern->previous->path ? pattern->previous->path->name : "NULL", + pattern->previous->pattern ? pattern->previous->pattern->type : -1); + } +#endif + renamePattern(pattern->current, path, + I); // previous will already have been named + // Record the path that must be bound before this comparison can execute + pattern->requiredPath = pattern->previous->path; +#ifdef DEBUG_TPMC_MATCH + eprintf("renameComparisonPattern EXIT: pattern path=%s, previous->path=%s, " + "current->path=%s, requiredPath=%s\n", + path ? path->name : "NULL", + pattern->previous->path ? pattern->previous->path->name : "NULL", + pattern->current->path ? pattern->current->path->name : "NULL", + pattern->requiredPath ? pattern->requiredPath->name : "NULL"); +#endif } static void renameAssignmentPattern(TpmcAssignmentPattern *pattern, - HashSymbol *path) { - renamePattern(pattern->value, path); + HashSymbol *path, ParserInfo I) { + renamePattern(pattern->value, path, I); } static void renameConstructorPattern(TpmcConstructorPattern *pattern, - HashSymbol *path) { + HashSymbol *path, ParserInfo I) { TpmcPatternArray *components = pattern->components; char buf[512]; for (Index i = 0; i < components->size; i++) { if (snprintf(buf, 512, "%s$%d", path->name, i) >= 511) { - can_happen("maximum path depth exceeded"); + can_happen(I, "maximum path depth exceeded"); } DEBUG("renameConstructorPattern: %s", buf); HashSymbol *newPath = newSymbol(buf); - renamePattern(components->entries[i], newPath); + renamePattern(components->entries[i], newPath, I); } } -static void renameTuplePattern(TpmcPatternArray *components, - HashSymbol *path) { +static void renameTuplePattern(TpmcPatternArray *components, HashSymbol *path, + ParserInfo I) { char buf[512]; for (Index i = 0; i < components->size; i++) { if (snprintf(buf, 512, "%s$%d", path->name, i) >= 511) { - can_happen("maximum path depth exceeded"); + can_happen(I, "maximum path depth exceeded"); } DEBUG("renameTuplePattern: %s", buf); HashSymbol *newPath = newSymbol(buf); - renamePattern(components->entries[i], newPath); + renamePattern(components->entries[i], newPath, I); } } -static void renamePattern(TpmcPattern *pattern, HashSymbol *variable) { +static void renamePattern(TpmcPattern *pattern, HashSymbol *variable, + ParserInfo I) { pattern->path = variable; switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_VAR: - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - case TPMCPATTERNVALUE_TYPE_WILDCARD: - case TPMCPATTERNVALUE_TYPE_CHARACTER: - break; - case TPMCPATTERNVALUE_TYPE_COMPARISON: - renameComparisonPattern(pattern->pattern->val.comparison, - variable); - break; - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - renameAssignmentPattern(pattern->pattern->val.assignment, - variable); - break; - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - renameConstructorPattern(pattern->pattern->val.constructor, - variable); - break; - case TPMCPATTERNVALUE_TYPE_TUPLE: - renameTuplePattern(pattern->pattern->val.tuple, variable); - break; - default: - cant_happen("unrecognised pattern type %s", tpmcPatternValueTypeName(pattern->pattern->type)); - } -} - -static void renameRule(TpmcMatchRule *rule, TpmcVariableArray *rootVariables, ParserInfo I) { + case TPMCPATTERNVALUE_TYPE_VAR: + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + case TPMCPATTERNVALUE_TYPE_WILDCARD: + case TPMCPATTERNVALUE_TYPE_CHARACTER: + break; + case TPMCPATTERNVALUE_TYPE_COMPARISON: + renameComparisonPattern(pattern->pattern->val.comparison, variable, I); + break; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + renameAssignmentPattern(pattern->pattern->val.assignment, variable, I); + break; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + renameConstructorPattern(pattern->pattern->val.constructor, variable, + I); + break; + case TPMCPATTERNVALUE_TYPE_TUPLE: + renameTuplePattern(pattern->pattern->val.tuple, variable, I); + break; + default: + cant_happen("unrecognised pattern type %s", + tpmcPatternValueTypeName(pattern->pattern->type)); + } +} + +static void renameRule(TpmcMatchRule *rule, SymbolArray *rootVariables, + ParserInfo I) { if (rule->patterns->size != rootVariables->size) { - can_happen("inconsistent number of arguments (%d vs %d) in +%d %s", rule->patterns->size, rootVariables->size, I.lineNo, I.fileName); + can_happen(I, "inconsistent number of arguments (%d vs %d)", + rule->patterns->size, rootVariables->size); // will crash otherwise. exit(1); } for (Index i = 0; i < rule->patterns->size; i++) { - renamePattern(rule->patterns->entries[i], rootVariables->entries[i]); + renamePattern(rule->patterns->entries[i], rootVariables->entries[i], I); } } @@ -378,23 +404,36 @@ static void renameRules(TpmcMatchRules *input, ParserInfo I) { } static TpmcPattern *replaceComparisonPattern(TpmcPattern *pattern, - TpmcPatternTable *seen); + TpmcPatternTable *seen, + ParserInfo I); static TpmcPattern *replaceVarPattern(TpmcPattern *pattern, TpmcPatternTable *seen) { TpmcPattern *other = NULL; if (getTpmcPatternTable(seen, pattern->pattern->val.var, &other)) { if (other->pattern->type == TPMCPATTERNVALUE_TYPE_ASSIGNMENT) { - // FIXME should be possible to allow this? assignments are just variable bindings - // would be necessary to refine the patternsMatchingPattern algorithm in tpmc_match.c:mixture() - can_happen("cannot compare assignment (var %s)", - pattern->pattern->val.var->name); + // Case B: assignment first (x=1, x) + // The assignment binds the variable at its position and matches + // its inner pattern. This VAR just needs to compare against that + // position. Use the assignment pattern as 'previous' - renaming + // will assign it the correct path. + TpmcPatternValue *val = + makeTpmcPatternValue_Comparison(other, pattern); + int save = PROTECT(val); + TpmcPattern *result = newTpmcPattern(val); + UNPROTECT(save); + return result; } - TpmcComparisonPattern *comp = - newTpmcComparisonPattern(other, pattern); - int save = PROTECT(comp); - TpmcPatternValue *val = newTpmcPatternValue_Comparison(comp); - PROTECT(val); + if (other->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON) { + // Multiple occurrences: extract the original binding site (first + // occurrence) All comparisons should point to the original VAR + // pattern, not to intermediate COMPARISON patterns + other = other->pattern->val.comparison->previous; + } + TpmcPatternValue *val = makeTpmcPatternValue_Comparison(other, pattern); + int save = PROTECT(val); + // Note: requiredPath is set later in renameComparisonPattern when paths + // are assigned TpmcPattern *result = newTpmcPattern(val); UNPROTECT(save); return result; @@ -405,195 +444,334 @@ static TpmcPattern *replaceVarPattern(TpmcPattern *pattern, } static TpmcPattern *replaceAssignmentPattern(TpmcPattern *pattern, - TpmcPatternTable *seen) { + TpmcPatternTable *seen, + ParserInfo I) { TpmcPattern *other = NULL; - if (getTpmcPatternTable - (seen, pattern->pattern->val.assignment->name, &other)) { - can_happen("cannot compare assignment (var %s)", - pattern->pattern->val.assignment->name->name); + if (getTpmcPatternTable(seen, pattern->pattern->val.assignment->name, + &other)) { + // After Case A pattern swapping in replaceComparisonRule, assignment + // should only see itself or another assignment in 'seen', never a VAR + if (other->pattern->type == TPMCPATTERNVALUE_TYPE_VAR) { + cant_happen("found VAR in seen when processing ASSIGNMENT - " + "pattern swapping failed"); + } + // Assignment-after-assignment is OK (duplicate assignment names) } else { setTpmcPatternTable(seen, pattern->pattern->val.assignment->name, pattern); } - pattern->pattern->val.assignment->value = - replaceComparisonPattern(pattern->pattern->val.assignment->value, - seen); + pattern->pattern->val.assignment->value = replaceComparisonPattern( + pattern->pattern->val.assignment->value, seen, I); return pattern; } static TpmcPattern *replaceConstructorPattern(TpmcPattern *pattern, - TpmcPatternTable *seen) { + TpmcPatternTable *seen, + ParserInfo I) { TpmcPatternArray *components = pattern->pattern->val.constructor->components; for (Index i = 0; i < components->size; ++i) { components->entries[i] = - replaceComparisonPattern(components->entries[i], seen); + replaceComparisonPattern(components->entries[i], seen, I); } return pattern; } static TpmcPattern *replaceTuplePattern(TpmcPattern *pattern, - TpmcPatternTable *seen) { + TpmcPatternTable *seen, ParserInfo I) { TpmcPatternArray *components = pattern->pattern->val.tuple; for (Index i = 0; i < components->size; ++i) { components->entries[i] = - replaceComparisonPattern(components->entries[i], seen); + replaceComparisonPattern(components->entries[i], seen, I); } return pattern; } static TpmcPattern *replaceComparisonPattern(TpmcPattern *pattern, - TpmcPatternTable *seen) { + TpmcPatternTable *seen, + ParserInfo I) { switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - case TPMCPATTERNVALUE_TYPE_WILDCARD: - case TPMCPATTERNVALUE_TYPE_CHARACTER: - return pattern; - case TPMCPATTERNVALUE_TYPE_VAR: - return replaceVarPattern(pattern, seen); - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - return replaceAssignmentPattern(pattern, seen); - case TPMCPATTERNVALUE_TYPE_TUPLE: - return replaceTuplePattern(pattern, seen); - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - return replaceConstructorPattern(pattern, seen); - case TPMCPATTERNVALUE_TYPE_COMPARISON: - cant_happen - ("encounterted nested comparison pattern during replaceComparisonPattern"); - default: - cant_happen("unrecognised pattern type %s", tpmcPatternValueTypeName(pattern->pattern->type)); - } -} - -static void replaceComparisonRule(TpmcMatchRule *rule) { + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + case TPMCPATTERNVALUE_TYPE_WILDCARD: + case TPMCPATTERNVALUE_TYPE_CHARACTER: + return pattern; + case TPMCPATTERNVALUE_TYPE_VAR: + return replaceVarPattern(pattern, seen); + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + return replaceAssignmentPattern(pattern, seen, I); + case TPMCPATTERNVALUE_TYPE_TUPLE: + return replaceTuplePattern(pattern, seen, I); + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + return replaceConstructorPattern(pattern, seen, I); + case TPMCPATTERNVALUE_TYPE_COMPARISON: + cant_happen("encounterted nested comparison pattern during " + "replaceComparisonPattern"); + default: + cant_happen("unrecognised pattern type %s", + tpmcPatternValueTypeName(pattern->pattern->type)); + } +} + +static void replaceComparisonRule(TpmcMatchRule *rule, ParserInfo I) { + // Pre-pass: detect Case A (VAR then ASSIGNMENT with same name) and swap + // them This transforms (x, x=1) into (x=1, x) so Case B logic handles it + TpmcPatternTable *varPositions = newTpmcPatternTable(); + int save = PROTECT(varPositions); + + // First pass: record VAR positions + for (Index i = 0; i < rule->patterns->size; i++) { + TpmcPattern *pattern = rule->patterns->entries[i]; + if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_VAR) { + setTpmcPatternTable(varPositions, pattern->pattern->val.var, + pattern); + } + } + + // Second pass: detect and swap Case A patterns + for (Index i = 0; i < rule->patterns->size; i++) { + TpmcPattern *pattern = rule->patterns->entries[i]; + if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_ASSIGNMENT) { + TpmcPattern *varPattern = NULL; + if (getTpmcPatternTable(varPositions, + pattern->pattern->val.assignment->name, + &varPattern)) { + // Found Case A: swap the VAR and ASSIGNMENT positions + // Find the VAR's index + for (Index j = 0; j < i; j++) { + if (rule->patterns->entries[j] == varPattern) { + // Swap patterns + rule->patterns->entries[j] = pattern; + rule->patterns->entries[i] = varPattern; + break; + } + } + } + } + } + + // Now process comparisons normally (Case B logic handles swapped patterns) TpmcPatternTable *seen = newTpmcPatternTable(); - int save = PROTECT(seen); + PROTECT(seen); for (Index i = 0; i < rule->patterns->size; i++) { rule->patterns->entries[i] = - replaceComparisonPattern(rule->patterns->entries[i], seen); + replaceComparisonPattern(rule->patterns->entries[i], seen, I); } UNPROTECT(save); validateLastAlloc(); } -static void replaceComparisonRules(TpmcMatchRules *input) { +static void replaceComparisonRules(TpmcMatchRules *input, ParserInfo I) { for (Index i = 0; i < input->rules->size; i++) { - replaceComparisonRule(input->rules->entries[i]); + replaceComparisonRule(input->rules->entries[i], I); } } -static TpmcPattern *collectPatternSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable - *substitutions); +static TpmcPattern *collectPatternSubstitutions(ParserInfo PI, + TpmcPattern *pattern, + SymbolMap *substitutions); + +static bool occursInPattern(HashSymbol *var, TpmcPattern *pattern, + HashSymbol *assignmentPath); + +static bool isPathAncestor(HashSymbol *ancestor, HashSymbol *descendant) { + // Check if ancestor path is a prefix of descendant path + // e.g., "p$0" is ancestor of "p$0$1" + const char *ancestorStr = ancestor->name; + const char *descendantStr = descendant->name; + size_t ancestorLen = strlen(ancestorStr); + + // Check if descendant starts with ancestor and the next char is '$' or end + if (strncmp(ancestorStr, descendantStr, ancestorLen) == 0) { + char nextChar = descendantStr[ancestorLen]; + return nextChar == '$' || nextChar == '\0'; + } + return false; +} -static TpmcPattern *collectVarSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable - *substitutions) { - setTpmcSubstitutionTable(substitutions, pattern->pattern->val.var, - pattern->path); +static bool occursInPattern(HashSymbol *var, TpmcPattern *pattern, + HashSymbol *assignmentPath) { + // If this pattern's path is a descendant of the assignment path, we have a + // cycle + if (assignmentPath != NULL && + isPathAncestor(assignmentPath, pattern->path)) { + // If this pattern actually contains the variable we're looking for, + // it's a true cycle + if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_VAR && + pattern->pattern->val.var == var) { + return true; + } + // Even if this specific pattern isn't the variable, stop recursing to + // prevent infinite loops The cycle detection happens at the pattern + // level, not the variable level + return false; + } + + switch (pattern->pattern->type) { + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + case TPMCPATTERNVALUE_TYPE_WILDCARD: + case TPMCPATTERNVALUE_TYPE_CHARACTER: + return false; + case TPMCPATTERNVALUE_TYPE_VAR: + return pattern->pattern->val.var == var; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + // Check if variable occurs in the assignment value, passing the + // assignment path + return occursInPattern(var, pattern->pattern->val.assignment->value, + pattern->path); + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + TpmcPatternArray *components = + pattern->pattern->val.constructor->components; + for (Index i = 0; i < components->size; ++i) { + if (occursInPattern(var, components->entries[i], assignmentPath)) { + return true; + } + } + return false; + } + case TPMCPATTERNVALUE_TYPE_TUPLE: { + TpmcPatternArray *components = pattern->pattern->val.tuple; + for (Index i = 0; i < components->size; ++i) { + if (occursInPattern(var, components->entries[i], assignmentPath)) { + return true; + } + } + return false; + } + case TPMCPATTERNVALUE_TYPE_COMPARISON: { + TpmcComparisonPattern *comp = pattern->pattern->val.comparison; + return occursInPattern(var, comp->previous, assignmentPath) || + occursInPattern(var, comp->current, assignmentPath); + } + default: + cant_happen("unrecognised pattern type %s", + tpmcPatternValueTypeName(pattern->pattern->type)); + } +} + +static TpmcPattern *collectVarSubstitutions(TpmcPattern *pattern, + SymbolMap *substitutions) { + setSymbolMap(substitutions, pattern->pattern->val.var, pattern->path); TpmcPatternValue *wc = newTpmcPatternValue_WildCard(); pattern->pattern = wc; return pattern; } -static TpmcPattern *collectAssignmentSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable - *substitutions) { - setTpmcSubstitutionTable(substitutions, - pattern->pattern->val.assignment->name, - pattern->path); - // we no longer need to remember this is an assignment now we have the substitution +static TpmcPattern *collectAssignmentSubstitutions(ParserInfo PI, + TpmcPattern *pattern, + SymbolMap *substitutions) { + HashSymbol *assignedVar = pattern->pattern->val.assignment->name; TpmcPattern *value = pattern->pattern->val.assignment->value; - return collectPatternSubstitutions(value, substitutions); + + // Perform occurs-in check to detect circular assignments like x = #(1, x) + if (occursInPattern(assignedVar, value, NULL)) { + can_happen(PI, + "occurs-in check failed: variable %s cannot match a " + "structure containing itself", + assignedVar->name); + // Return a wildcard pattern to avoid further processing issues + TpmcPatternValue *wc = newTpmcPatternValue_WildCard(); + pattern->pattern = wc; + return pattern; + } + + setSymbolMap(substitutions, assignedVar, pattern->path); + // we no longer need to remember this is an assignment now we have the + // substitution + return collectPatternSubstitutions(PI, value, substitutions); } -static TpmcPattern *collectConstructorSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable - *substitutions) { +static TpmcPattern *collectConstructorSubstitutions(ParserInfo PI, + TpmcPattern *pattern, + SymbolMap *substitutions) { TpmcPatternArray *components = pattern->pattern->val.constructor->components; for (Index i = 0; i < components->size; ++i) { - components->entries[i] = - collectPatternSubstitutions(components->entries[i], - substitutions); + components->entries[i] = collectPatternSubstitutions( + PI, components->entries[i], substitutions); } return pattern; } -static TpmcPattern *collectTupleSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable *substitutions) { - TpmcPatternArray *components = - pattern->pattern->val.tuple; +static TpmcPattern *collectTupleSubstitutions(ParserInfo PI, + TpmcPattern *pattern, + SymbolMap *substitutions) { + TpmcPatternArray *components = pattern->pattern->val.tuple; for (Index i = 0; i < components->size; ++i) { - components->entries[i] = - collectPatternSubstitutions(components->entries[i], - substitutions); + components->entries[i] = collectPatternSubstitutions( + PI, components->entries[i], substitutions); } return pattern; } -static TpmcPattern *collectComparisonSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable - *substitutions) { +static TpmcPattern *collectComparisonSubstitutions(ParserInfo PI, + TpmcPattern *pattern, + SymbolMap *substitutions) { + // Process previous to collect substitutions - this is where the variable + // name should be bound (first occurrence) TpmcPattern *previous = pattern->pattern->val.comparison->previous; pattern->pattern->val.comparison->previous = - collectPatternSubstitutions(previous, substitutions); - pattern->pattern->val.comparison->current = - collectPatternSubstitutions(pattern->pattern->val.comparison->current, - substitutions); + collectPatternSubstitutions(PI, previous, substitutions); + // Note: Do NOT process current for substitutions. + // The current is only used for the equality comparison in the DFA, + // not for substitution into the body. The variable name was already + // bound by previous. Processing current would incorrectly add its path + // to free variables and potentially overwrite the correct substitution. return pattern; } static void performActionSubstitution(TpmcState *state, - TpmcSubstitutionTable *substitutions) { + SymbolMap *substitutions) { if (state->state->type != TPMCSTATEVALUE_TYPE_FINAL) { - cant_happen - ("attempt to call performActionSubstitution on non-final state"); + cant_happen( + "attempt to call performActionSubstitution on non-final state"); } state->state->val.final->action = - lamPerformSubstitutions(state->state->val.final->action, - substitutions); + lamPerformSubstitutions(state->state->val.final->action, substitutions); } -static void populateFreeVariables(TpmcState *state, - TpmcSubstitutionTable *substitutions) { +static void populateFreeVariables(TpmcState *state, SymbolMap *substitutions) { if (state->state->type != TPMCSTATEVALUE_TYPE_FINAL) { - cant_happen - ("attempt to call populateFreeCariables on non-final state"); + cant_happen("attempt to call populateFreeCariables on non-final state"); } - state->freeVariables = newTpmcVariableTable(); + state->freeVariables = newSymbolSet(); Index i = 0; HashSymbol *path = NULL; HashSymbol *key; - while ((key = - iterateTpmcSubstitutionTable(substitutions, &i, &path)) != NULL) { - setTpmcVariableTable(state->freeVariables, path); + while ((key = iterateSymbolMap(substitutions, &i, &path)) != NULL) { + setSymbolSet(state->freeVariables, path); } } -static TpmcPattern *collectPatternSubstitutions(TpmcPattern *pattern, TpmcSubstitutionTable - *substitutions) { +static TpmcPattern *collectPatternSubstitutions(ParserInfo PI, + TpmcPattern *pattern, + SymbolMap *substitutions) { switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - case TPMCPATTERNVALUE_TYPE_WILDCARD: - case TPMCPATTERNVALUE_TYPE_CHARACTER: - return pattern; - case TPMCPATTERNVALUE_TYPE_VAR: - return collectVarSubstitutions(pattern, substitutions); - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - return collectAssignmentSubstitutions(pattern, substitutions); - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - return collectConstructorSubstitutions(pattern, substitutions); - case TPMCPATTERNVALUE_TYPE_TUPLE: - return collectTupleSubstitutions(pattern, substitutions); - case TPMCPATTERNVALUE_TYPE_COMPARISON: - return collectComparisonSubstitutions(pattern, substitutions); - default: - cant_happen("unrecognised pattern type %s", tpmcPatternValueTypeName(pattern->pattern->type)); - } -} - -static void performRuleSubstitutions(TpmcMatchRule *rule) { - TpmcSubstitutionTable *substitutions = newTpmcSubstitutionTable(); + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + case TPMCPATTERNVALUE_TYPE_WILDCARD: + case TPMCPATTERNVALUE_TYPE_CHARACTER: + return pattern; + case TPMCPATTERNVALUE_TYPE_VAR: + return collectVarSubstitutions(pattern, substitutions); + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + return collectAssignmentSubstitutions(PI, pattern, substitutions); + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + return collectConstructorSubstitutions(PI, pattern, substitutions); + case TPMCPATTERNVALUE_TYPE_TUPLE: + return collectTupleSubstitutions(PI, pattern, substitutions); + case TPMCPATTERNVALUE_TYPE_COMPARISON: + return collectComparisonSubstitutions(PI, pattern, substitutions); + default: + cant_happen("unrecognised pattern type %s", + tpmcPatternValueTypeName(pattern->pattern->type)); + } +} + +static void performRuleSubstitutions(ParserInfo PI, TpmcMatchRule *rule) { + SymbolMap *substitutions = newSymbolMap(); int save = PROTECT(substitutions); for (Index i = 0; i < rule->patterns->size; i++) { - rule->patterns->entries[i] = - collectPatternSubstitutions(rule->patterns->entries[i], - substitutions); + rule->patterns->entries[i] = collectPatternSubstitutions( + PI, rule->patterns->entries[i], substitutions); } performActionSubstitution(rule->action, substitutions); populateFreeVariables(rule->action, substitutions); @@ -601,12 +779,13 @@ static void performRuleSubstitutions(TpmcMatchRule *rule) { } /** - * @brief Iterates `performRuleSubstitutions` over all rules in a TpmcMatchRules. + * @brief Iterates `performRuleSubstitutions` over all rules in a + * TpmcMatchRules. * @param input The match rules to process. */ -static void performRulesSubstitutions(TpmcMatchRules *input) { +static void performRulesSubstitutions(ParserInfo PI, TpmcMatchRules *input) { for (Index i = 0; i < input->rules->size; i++) { - performRuleSubstitutions(input->rules->entries[i]); + performRuleSubstitutions(PI, input->rules->entries[i]); } } @@ -662,55 +841,54 @@ static TpmcMatrix *convertToMatrix(TpmcMatchRules *input) { /** * Helper for `arrayToVarList`. */ -static LamVarList *_arrayToVarList(ParserInfo I, TpmcVariableArray *array, Index count) { +static SymbolList *_arrayToVarList(ParserInfo I, SymbolArray *array, + Index count) { if (count == array->size) { return NULL; } - LamVarList *next = _arrayToVarList(I, array, count + 1); + SymbolList *next = _arrayToVarList(I, array, count + 1); int save = PROTECT(next); - LamVarList *this = newLamVarList(I, array->entries[count], next); + SymbolList *this = newSymbolList(I, array->entries[count], next); UNPROTECT(save); return this; } /** - * @brief Converts a TpmcVariableArray into a LamVarList, preserving the order. + * @brief Converts a SymbolArray into a SymbolList, preserving the order. * @param I Parser information. - * @param array The TpmcVariableArray to convert. - * @return A new LamVarList representing the variables in the array. + * @param array The SymbolArray to convert. + * @return A new SymbolList representing the variables in the array. */ -static LamVarList *arrayToVarList(ParserInfo I, TpmcVariableArray *array) { +static SymbolList *arrayToVarList(ParserInfo I, SymbolArray *array) { return _arrayToVarList(I, array, 0); } /** - * @brief Converts the AST formal argument lists and bodies of a composite function - * into a single lambda that switches on its arguments. - * @context This function is the entry point to the Term Pattern Matching Compiler (TPMC) + * @brief Converts the AST formal argument lists and bodies of a composite + * function into a single lambda that switches on its arguments. + * @context This function is the entry point to the Term Pattern Matching + * Compiler (TPMC) * @param allow_unsafe whether to allow a non-exhaustive pattern match. * @param I Parser information. - * @param nArgs The number of arguments (each component function must have the same number of arguments). + * @param nArgs The number of arguments (each component function must have the + * same number of arguments). * @param nbodies The number of bodies (component functions). * @param argLists The argument lists. * @param bodies The function bodies. * @return A new lambda representing the converted function. */ -LamLam *tpmcConvert(bool allow_unsafe, - ParserInfo I, - int nArgs, - int nbodies, - AstFargList **argLists, - LamExp **bodies, - LamContext *env) { - TpmcVariableArray *rootVariables = createRootVariables(nArgs); +LamLam *tpmcConvert(bool allow_unsafe, ParserInfo I, int nArgs, int nbodies, + AstFargList **argLists, LamExp **bodies, LamContext *env) { + SymbolArray *rootVariables = createRootVariables(nArgs); int save = PROTECT(rootVariables); - TpmcMatchRuleArray *rules = convertComposite(nbodies, argLists, bodies, env); + TpmcMatchRuleArray *rules = + convertComposite(nbodies, argLists, bodies, env); PROTECT(rules); TpmcMatchRules *input = newTpmcMatchRules(rules, rootVariables); REPLACE_PROTECT(save, input); - replaceComparisonRules(input); + replaceComparisonRules(input, I); renameRules(input, I); - performRulesSubstitutions(input); + performRulesSubstitutions(I, input); TpmcMatrix *matrix = convertToMatrix(input); PROTECT(matrix); IFDEBUG(ppTpmcMatrix(matrix)); @@ -723,12 +901,13 @@ LamLam *tpmcConvert(bool allow_unsafe, } TpmcState *errorState = makeErrorState(); PROTECT(errorState); - TpmcState *dfa = tpmcMatch(matrix, finalStates, errorState, knownStates, allow_unsafe, I); + TpmcState *dfa = tpmcMatch(matrix, finalStates, errorState, knownStates, + allow_unsafe, I); PROTECT(dfa); tpmcMermaid(dfa); LamExp *body = tpmcTranslate(I, dfa); PROTECT(body); - LamVarList *args = arrayToVarList(I, rootVariables); + SymbolList *args = arrayToVarList(I, rootVariables); PROTECT(args); LamLam *res = newLamLam(I, args, body); PROTECT(res); diff --git a/src/tpmc_match.c b/src/tpmc_match.c index b3d9c253..595bfcbf 100644 --- a/src/tpmc_match.c +++ b/src/tpmc_match.c @@ -18,29 +18,30 @@ * Term Pattern Matching Compiler match algorithm */ -#include -#include -#include -#include "common.h" #include "tpmc_match.h" -#include "tpmc_compare.h" -#include "tpmc_debug.h" -#include "tpmc_pp.h" +#include "common.h" #include "lambda_debug.h" #include "lambda_helper.h" +#include "parser_info.h" #include "symbol.h" +#include "tpmc_compare.h" +#include "tpmc_debug.h" +#include "tpmc_pp.h" #include "types.h" -#include "parser_info.h" +#include +#include +#include #ifdef DEBUG_TPMC_MATCH -# include "debugging_on.h" +#include "debugging_on.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif static TpmcState *match(TpmcMatrix *matrix, TpmcStateArray *finalStates, TpmcState *errorState, TpmcStateArray *knownStates, - TpmcStateTable *stateTable, bool *unsafe, ParserInfo I); + TpmcStateTable *stateTable, bool *unsafe, + SymbolSet *testedPaths, ParserInfo I); static HashSymbol *stampToSymbol(int stamp) { char buf[32]; @@ -56,16 +57,19 @@ TpmcState *tpmcMatch(TpmcMatrix *matrix, TpmcStateArray *finalStates, #endif TpmcStateTable *stateTable = newTpmcStateTable(); int save = PROTECT(stateTable); + SymbolSet *testedPaths = newSymbolSet(); + PROTECT(testedPaths); bool unsafe = false; - TpmcState *result = match(matrix, finalStates, errorState, knownStates, stateTable, &unsafe, I); + TpmcState *result = match(matrix, finalStates, errorState, knownStates, + stateTable, &unsafe, testedPaths, I); UNPROTECT(save); if (unsafe) { if (!allow_unsafe) { - can_happen("unsafe function must be declared unsafe at %s line %d", I.fileName, I.lineNo); + can_happen(I, "unsafe function must be declared unsafe"); } } else { if (allow_unsafe) { - can_happen("safe function declared unsafe at %s line %d", I.fileName, I.lineNo); + can_happen(I, "safe function declared unsafe"); } } return result; @@ -76,6 +80,10 @@ TpmcState *tpmcMakeState(TpmcStateValue *val) { return newTpmcState(counter++, val); } +// ============================================================================ +// Pattern Classification & Checking Utilities +// ============================================================================ + static bool patternIsWildCard(TpmcPattern *pattern) { return pattern->pattern->type == TPMCPATTERNVALUE_TYPE_WILDCARD; } @@ -84,40 +92,110 @@ static bool patternIsComparison(TpmcPattern *pattern) { return pattern->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON; } -static bool topRowOnlyVariables(TpmcMatrix *matrix) { +// Check if 'prefix' is a path prefix of 'path'. +// Path names are like "p$106$0$1" - prefix "p$106$0" should match. +// This returns true if 'path' starts with 'prefix' followed by '$' or end. +static bool pathIsPrefix(HashSymbol *prefix, HashSymbol *path) { + if (prefix == path) { + return true; // Exact match + } + const char *prefixStr = prefix->name; + const char *pathStr = path->name; + size_t prefixLen = strlen(prefixStr); + // Check if path starts with prefix and next char is '$' (sub-component) + if (strncmp(pathStr, prefixStr, prefixLen) == 0 && + pathStr[prefixLen] == '$') { + return true; + } + return false; +} + +// Check if a comparison's required path is available (is a column header, +// has been deconstructed, i.e., a column header is a child of the required +// path, or has already been tested in a parent mixture() call) +static bool comparisonIsReady(TpmcPattern *pattern, TpmcMatrix *matrix, + SymbolSet *testedPaths) { + if (pattern->pattern->type != TPMCPATTERNVALUE_TYPE_COMPARISON) { + return true; // Not a comparison, always ready + } + HashSymbol *required = pattern->pattern->val.comparison->requiredPath; + if (required == NULL) { + DEBUG( + "comparisonIsReady: pattern %s has no requiredPath, returning true", + pattern->path ? pattern->path->name : "(null)"); + return true; // No requirement recorded + } + DEBUG("comparisonIsReady: pattern %s requires %s", + pattern->path ? pattern->path->name : "(null)", required->name); + // First check if required path was already tested in a parent mixture() + if (testedPaths != NULL && getSymbolSet(testedPaths, required)) { + DEBUG(" FOUND required path in testedPaths, returning true"); + return true; + } + // Check if required path is a column header OR has been deconstructed + // (a column header is a child of the required path, meaning the required + // path was already matched and expanded) for (Index x = 0; x < matrix->width; x++) { - if (!patternIsWildCard(getTpmcMatrixIndex(matrix, x, 0))) { - return false; + TpmcPattern *top = getTpmcMatrixIndex(matrix, x, 0); + DEBUG(" column %d header: %s", x, + top->path ? top->path->name : "(null)"); + if (top->path != NULL && pathIsPrefix(required, top->path)) { + DEBUG( + " FOUND required path (or child) at column %d, returning true", + x); + return true; } } + DEBUG(" required path NOT found, returning false"); + return false; // Required path is nested, not yet available +} + +// A pattern is actionable if it's not a wildcard and not a non-ready comparison +static bool patternIsActionable(TpmcPattern *pattern, TpmcMatrix *matrix, + SymbolSet *testedPaths) { + if (patternIsWildCard(pattern)) { + return false; + } + // Non-ready comparisons are treated as wildcards for column selection + if (patternIsComparison(pattern) && + !comparisonIsReady(pattern, matrix, testedPaths)) { + return false; + } return true; } -static bool columnHasComparisons(int x, TpmcMatrix *matrix) { - for (Index y = 0; y < matrix->height; y++) { - if (patternIsComparison(getTpmcMatrixIndex(matrix, x, y))) { - return true; +// Check if top row has only wildcards or non-ready comparisons (nothing +// actionable) +static bool topRowHasNoActionablePatterns(TpmcMatrix *matrix, + SymbolSet *testedPaths) { + for (Index x = 0; x < matrix->width; x++) { + if (patternIsActionable(getTpmcMatrixIndex(matrix, x, 0), matrix, + testedPaths)) { + return false; } } - return false; + return true; } -static int findFirstConstructorColumn(TpmcMatrix *matrix) { +// Find first column with an actionable pattern (constructor, literal, or ready +// comparison) +static int findFirstActionableColumn(TpmcMatrix *matrix, + SymbolSet *testedPaths) { for (Index x = 0; x < matrix->width; x++) { - if (!patternIsWildCard(getTpmcMatrixIndex(matrix, x, 0))) { - DEBUG("findFirstConstructorColumn(%d x %d) => %d", matrix->width, matrix->height, x); + if (patternIsActionable(getTpmcMatrixIndex(matrix, x, 0), matrix, + testedPaths)) { + DEBUG("findFirstActionableColumn(%d x %d) => %d", matrix->width, + matrix->height, x); return x; } } - cant_happen("findFirstConstructorColumn failed"); + cant_happen("findFirstActionableColumn failed"); } static TpmcState *makeEmptyTestState(HashSymbol *path) { TpmcArcArray *arcs = newTpmcArcArray(); int save = PROTECT(arcs); - TpmcTestState *test = newTpmcTestState(path, arcs); - PROTECT(test); - TpmcStateValue *val = newTpmcStateValue_Test(test); + TpmcStateValue *val = makeTpmcStateValue_Test(path, arcs); PROTECT(val); TpmcState *testState = tpmcMakeState(val); UNPROTECT(save); @@ -125,86 +203,105 @@ static TpmcState *makeEmptyTestState(HashSymbol *path) { } static bool patternMatches(TpmcPattern *constructor, TpmcPattern *pattern) { - bool isComparison = + // When constructor is a comparison pattern, it should only match the same + // comparison (for deduplication) or wildcards. It should NOT match other + // constructors, because comparisons are guards that belong in the wildcard + // partition during row selection, not mixed with specific constructors. + bool constructorIsComparison = (constructor->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON); switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_VAR: - cant_happen("patternMatches encountered var"); - case TPMCPATTERNVALUE_TYPE_COMPARISON: - return eqTpmcPattern(constructor, pattern); - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - cant_happen("patternMatches encountered assignment"); - case TPMCPATTERNVALUE_TYPE_WILDCARD: - return true; - case TPMCPATTERNVALUE_TYPE_CHARACTER:{ - bool res = isComparison - || (constructor->pattern->type == - TPMCPATTERNVALUE_TYPE_CHARACTER - && constructor->pattern->val.character == - pattern->pattern->val.character); - return res; - } - case TPMCPATTERNVALUE_TYPE_BIGINTEGER:{ - bool res = isComparison - || (constructor->pattern->type == - TPMCPATTERNVALUE_TYPE_BIGINTEGER - && cmpMaybeBigInt(constructor->pattern->val.bigInteger, - pattern->pattern->val.bigInteger) == 0); - return res; - } - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ - // remember the "constructor" is really just "not a wildCard" - bool res = - (constructor->pattern->type == - TPMCPATTERNVALUE_TYPE_CONSTRUCTOR && - // pointer equivalence works for hash symbols - constructor->pattern->val.constructor->tag == - pattern->pattern->val.constructor->tag) || isComparison; - return res; - } - case TPMCPATTERNVALUE_TYPE_TUPLE:{ - bool res = - (constructor->pattern->type == TPMCPATTERNVALUE_TYPE_TUPLE) || isComparison; - if (countTpmcPatternArray(constructor->pattern->val.tuple) != - countTpmcPatternArray(pattern->pattern->val.tuple)) { - can_happen("tuple arity mismatch"); - return false; - } - return res; - } - default: - cant_happen("unrecognized pattern type %s", - tpmcPatternValueTypeName(pattern->pattern->type)); + case TPMCPATTERNVALUE_TYPE_VAR: + cant_happen("patternMatches encountered var"); + case TPMCPATTERNVALUE_TYPE_COMPARISON: + // Both are comparisons - check for equality + return eqTpmcPattern(constructor, pattern); + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + cant_happen("patternMatches encountered assignment"); + case TPMCPATTERNVALUE_TYPE_WILDCARD: + // Wildcards match anything + return true; + case TPMCPATTERNVALUE_TYPE_CHARACTER: { + // Comparison patterns do not match literal characters for row + // partitioning - comparisons belong in wildcard partition + bool res = + !constructorIsComparison && + (constructor->pattern->type == TPMCPATTERNVALUE_TYPE_CHARACTER && + constructor->pattern->val.character == + pattern->pattern->val.character); + return res; + } + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: { + // Comparison patterns do not match literal integers for row + // partitioning - comparisons belong in wildcard partition + bool res = + !constructorIsComparison && + (constructor->pattern->type == TPMCPATTERNVALUE_TYPE_BIGINTEGER && + cmpMaybeBigInt(constructor->pattern->val.bigInteger, + pattern->pattern->val.bigInteger) == 0); + return res; + } + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + // Comparison patterns do not match constructors for row partitioning - + // comparisons are guards that belong in the wildcard partition, not + // mixed with specific constructor arcs. Remember the first arg + // "constructor" is really just "not a wildCard". + bool res = + !constructorIsComparison && + (constructor->pattern->type == TPMCPATTERNVALUE_TYPE_CONSTRUCTOR && + // pointer equivalence works for hash symbols + constructor->pattern->val.constructor->tag == + pattern->pattern->val.constructor->tag); + return res; + } + case TPMCPATTERNVALUE_TYPE_TUPLE: { + // Comparison patterns do not match tuples for row partitioning - + // comparisons belong in wildcard partition + bool res = !constructorIsComparison && + (constructor->pattern->type == TPMCPATTERNVALUE_TYPE_TUPLE); + if (res && countTpmcPatternArray(constructor->pattern->val.tuple) != + countTpmcPatternArray(pattern->pattern->val.tuple)) { + can_happen(NULLPI, "tuple arity mismatch"); + return false; + } + return res; + } + default: + cant_happen("unrecognized pattern type %s", + tpmcPatternValueTypeName(pattern->pattern->type)); } } -TpmcIntArray *findPatternsMatching(TpmcPattern *c, TpmcPatternArray *N) { - TpmcIntArray *res = newTpmcIntArray(); +IntArray *findPatternsMatching(TpmcPattern *pattern, TpmcPatternArray *column) { + IntArray *res = newIntArray(); int save = PROTECT(res); Index i = 0; TpmcPattern *candidate; - while (iterateTpmcPatternArray(N, &i, &candidate, NULL)) { - if (patternMatches(c, candidate)) { - pushTpmcIntArray(res, i - 1); + while (iterateTpmcPatternArray(column, &i, &candidate, NULL)) { + if (patternMatches(pattern, candidate)) { + pushIntArray(res, i - 1); } } UNPROTECT(save); return res; } -static TpmcPatternArray *extractColumnSubset(TpmcIntArray *ys, - TpmcPatternArray *N) { +static TpmcPatternArray *extractColumnSubset(IntArray *indices, + TpmcPatternArray *column) { TpmcPatternArray *res = newTpmcPatternArray("extractColumnSubset"); int save = PROTECT(res); Index i = 0; - int y; - while (iterateTpmcIntArray(ys, &i, &y, NULL)) { - pushTpmcPatternArray(res, N->entries[y]); + int index; + while (iterateIntArray(indices, &i, &index, NULL)) { + pushTpmcPatternArray(res, column->entries[index]); } UNPROTECT(save); return res; } +// ============================================================================ +// Matrix Operations +// ============================================================================ + static TpmcPatternArray *extractMatrixColumn(int x, TpmcMatrix *matrix) { TpmcPatternArray *res = newTpmcPatternArray("extractMatrixColumn"); int save = PROTECT(res); @@ -221,8 +318,7 @@ static TpmcMatrix *discardMatrixColumn(Index column, TpmcMatrix *matrix) { for (Index x = 0; x < matrix->width; x++) { for (Index y = 0; y < matrix->height; y++) { if (x < column) { - setTpmcMatrixIndex(res, x, y, - getTpmcMatrixIndex(matrix, x, y)); + setTpmcMatrixIndex(res, x, y, getTpmcMatrixIndex(matrix, x, y)); } else if (x > column) { setTpmcMatrixIndex(res, x - 1, y, getTpmcMatrixIndex(matrix, x, y)); @@ -235,17 +331,15 @@ static TpmcMatrix *discardMatrixColumn(Index column, TpmcMatrix *matrix) { return res; } -static TpmcMatrix *extractMatrixRows(TpmcIntArray *indices, - TpmcMatrix *matrix) { +static TpmcMatrix *extractMatrixRows(IntArray *indices, TpmcMatrix *matrix) { TpmcMatrix *res = newTpmcMatrix(matrix->width, indices->size); int save = PROTECT(res); int resy = 0; int iy = 0; Index i = 0; - while (iterateTpmcIntArray(indices, &i, &iy, NULL)) { + while (iterateIntArray(indices, &i, &iy, NULL)) { for (Index x = 0; x < res->width; ++x) { - setTpmcMatrixIndex(res, x, resy, - getTpmcMatrixIndex(matrix, x, iy)); + setTpmcMatrixIndex(res, x, resy, getTpmcMatrixIndex(matrix, x, iy)); } resy++; } @@ -255,9 +349,9 @@ static TpmcMatrix *extractMatrixRows(TpmcIntArray *indices, static TpmcMatrix *appendMatrices(TpmcMatrix *prefix, TpmcMatrix *suffix) { if (prefix->height != suffix->height) { - cant_happen - ("appendMatrices given matrices with different heights, %d vs %d", - prefix->height, suffix->height); + cant_happen( + "appendMatrices given matrices with different heights, %d vs %d", + prefix->height, suffix->height); } TpmcMatrix *res = newTpmcMatrix(prefix->width + suffix->width, prefix->height); @@ -265,12 +359,11 @@ static TpmcMatrix *appendMatrices(TpmcMatrix *prefix, TpmcMatrix *suffix) { for (Index x = 0; x < res->width; ++x) { for (Index y = 0; y < res->height; ++y) { if (x >= prefix->width) { - setTpmcMatrixIndex(res, x, y, - getTpmcMatrixIndex(suffix, - x - prefix->width, y)); + setTpmcMatrixIndex( + res, x, y, + getTpmcMatrixIndex(suffix, x - prefix->width, y)); } else { - setTpmcMatrixIndex(res, x, y, - getTpmcMatrixIndex(prefix, x, y)); + setTpmcMatrixIndex(res, x, y, getTpmcMatrixIndex(prefix, x, y)); } } } @@ -278,7 +371,8 @@ static TpmcMatrix *appendMatrices(TpmcMatrix *prefix, TpmcMatrix *suffix) { return res; } -static TpmcStateArray *extractStateArraySubset(TpmcIntArray *indices, TpmcStateArray *all) { +static TpmcStateArray *extractStateArraySubset(IntArray *indices, + TpmcStateArray *all) { TpmcStateArray *res = newTpmcStateArray("extractStateArraySubset"); int save = PROTECT(res); for (Index i = 0; i < indices->size; ++i) { @@ -289,33 +383,34 @@ static TpmcStateArray *extractStateArraySubset(TpmcIntArray *indices, TpmcStateA return res; } +// ============================================================================ +// Pattern Transformation & Analysis +// ============================================================================ + static int arityOf(TpmcPattern *pattern) { switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ - LamTypeConstructorInfo *info = - pattern->pattern->val.constructor->info; - return info->arity; - } - case TPMCPATTERNVALUE_TYPE_TUPLE: - return countTpmcPatternArray(pattern->pattern->val.tuple); - default: - return 0; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + LamTypeConstructorInfo *info = pattern->pattern->val.constructor->info; + return info->arity; + } + case TPMCPATTERNVALUE_TYPE_TUPLE: + return countTpmcPatternArray(pattern->pattern->val.tuple); + default: + return 0; } } -static void populateSubPatternMatrixRowWithWildCards(TpmcMatrix *matrix, - int y, int arity, +static void populateSubPatternMatrixRowWithWildCards(TpmcMatrix *matrix, int y, + int arity, TpmcPattern *pattern) { // FIXME safeMalloc this from strlen + some n char buf[512]; for (int i = 0; i < arity; i++) { if (snprintf(buf, 512, "%s$%d", pattern->path->name, i) > 510) { - cant_happen - ("internal structure limit exceeded in arg processing"); + cant_happen("internal structure limit exceeded in arg processing"); } HashSymbol *path = newSymbol(buf); - TpmcPatternValue *wc = - newTpmcPatternValue_WildCard(); + TpmcPatternValue *wc = newTpmcPatternValue_WildCard(); int save = PROTECT(wc); setTpmcMatrixIndex(matrix, i, y, newTpmcPattern(wc)); getTpmcMatrixIndex(matrix, i, y)->path = path; @@ -324,14 +419,14 @@ static void populateSubPatternMatrixRowWithWildCards(TpmcMatrix *matrix, } static void populateSubPatternMatrixRowWithConstructor(TpmcMatrix *matrix, - int y, Index arity, - TpmcPattern *pattern, - ParserInfo I) { + int y, Index arity, + TpmcPattern *pattern, + ParserInfo I) { if (arity != pattern->pattern->val.constructor->components->size) { ppTpmcPattern(pattern); - can_happen - ("\narity %d does not match constructor arity %d at %s line %d", - arity, pattern->pattern->val.constructor->components->size, I.fileName, I.lineNo); + can_happen(I, "\narity %d does not match constructor \"%s\" arity %d", + arity, pattern->pattern->val.constructor->info->name->name, + pattern->pattern->val.constructor->components->size); exit(1); } for (Index i = 0; i < arity; i++) { @@ -341,16 +436,15 @@ static void populateSubPatternMatrixRowWithConstructor(TpmcMatrix *matrix, } } -static void populateSubPatternMatrixRowWithTuple(TpmcMatrix *matrix, - int y, Index arity, +static void populateSubPatternMatrixRowWithTuple(TpmcMatrix *matrix, int y, + Index arity, TpmcPattern *pattern, ParserInfo I) { if (arity != countTpmcPatternArray(pattern->pattern->val.tuple)) { ppTpmcPattern(pattern); - can_happen - ("arity %d does not match tuple arity %d at %s line %d", - arity, countTpmcPatternArray(pattern->pattern->val.tuple), I.fileName, I.lineNo); - exit(1); + can_happen(I, "arity %d does not match tuple arity %d", arity, + countTpmcPatternArray(pattern->pattern->val.tuple)); + exit(1); } for (Index i = 0; i < arity; i++) { TpmcPattern *entry = pattern->pattern->val.tuple->entries[i]; @@ -358,7 +452,8 @@ static void populateSubPatternMatrixRowWithTuple(TpmcMatrix *matrix, } } -static TpmcMatrix *makeSubPatternMatrix(TpmcPatternArray *patterns, int arity, ParserInfo I) { +static TpmcMatrix *makeSubPatternMatrix(TpmcPatternArray *patterns, int arity, + ParserInfo I) { TpmcMatrix *matrix = newTpmcMatrix(arity, patterns->size); if (arity == 0) { return matrix; @@ -367,37 +462,37 @@ static TpmcMatrix *makeSubPatternMatrix(TpmcPatternArray *patterns, int arity, P for (Index i = 0; i < patterns->size; ++i) { TpmcPattern *pattern = patterns->entries[i]; switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_VAR: - cant_happen - ("encountered pattern type var during makeSubPatternMatrix"); - case TPMCPATTERNVALUE_TYPE_COMPARISON: - case TPMCPATTERNVALUE_TYPE_WILDCARD: - populateSubPatternMatrixRowWithWildCards(matrix, i, arity, - pattern); - break; - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - populateSubPatternMatrixRowWithConstructor(matrix, i, arity, - pattern, I); - break; - case TPMCPATTERNVALUE_TYPE_TUPLE: - populateSubPatternMatrixRowWithTuple(matrix, i, arity, pattern, I); - break; - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - cant_happen("encountered pattern type assignment"); - case TPMCPATTERNVALUE_TYPE_CHARACTER: - cant_happen("encountered pattern type char"); - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - cant_happen("encountered pattern type int"); - default: - cant_happen("unrecognised pattern type %s", - tpmcPatternValueTypeName(pattern->pattern->type)); + case TPMCPATTERNVALUE_TYPE_VAR: + cant_happen( + "encountered pattern type var during makeSubPatternMatrix"); + case TPMCPATTERNVALUE_TYPE_COMPARISON: + case TPMCPATTERNVALUE_TYPE_WILDCARD: + populateSubPatternMatrixRowWithWildCards(matrix, i, arity, pattern); + break; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + populateSubPatternMatrixRowWithConstructor(matrix, i, arity, + pattern, I); + break; + case TPMCPATTERNVALUE_TYPE_TUPLE: + populateSubPatternMatrixRowWithTuple(matrix, i, arity, pattern, I); + break; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + cant_happen("encountered pattern type assignment"); + case TPMCPATTERNVALUE_TYPE_CHARACTER: + cant_happen("encountered pattern type char"); + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + cant_happen("encountered pattern type int"); + default: + cant_happen("unrecognised pattern type %s", + tpmcPatternValueTypeName(pattern->pattern->type)); } } UNPROTECT(save); return matrix; } -static TpmcPatternArray *replaceComponentsWithWildCards(TpmcPatternArray *components) { +static TpmcPatternArray * +replaceComponentsWithWildCards(TpmcPatternArray *components) { ENTER(replaceComponentsWithWildCards); TpmcPatternArray *result = newTpmcPatternArray("replaceComponentsWithWildCards"); @@ -417,83 +512,98 @@ static TpmcPatternArray *replaceComponentsWithWildCards(TpmcPatternArray *compon return result; } -static TpmcPattern *replacePatternComponentsWithWildCards(TpmcPattern *pattern) { +static TpmcPattern * +replacePatternComponentsWithWildCards(TpmcPattern *pattern) { switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { - TpmcConstructorPattern *constructor = - pattern->pattern->val.constructor; - if (constructor->components->size > 0) { - TpmcPatternArray *components = replaceComponentsWithWildCards(constructor->components); - int save = PROTECT(components); - TpmcConstructorPattern *newCons = - newTpmcConstructorPattern(constructor->tag, constructor->nameSpace, constructor->info, - components); - PROTECT(newCons); - TpmcPatternValue *patternValue = - newTpmcPatternValue_Constructor(newCons); - PROTECT(patternValue); - TpmcPattern *replacement = newTpmcPattern(patternValue); - replacement->path = pattern->path; - UNPROTECT(save); - return replacement; - } else { - return pattern; - } - } - case TPMCPATTERNVALUE_TYPE_TUPLE: { - TpmcPatternArray *tuple = pattern->pattern->val.tuple; - if (tuple->size > 0) { - TpmcPatternArray *components = replaceComponentsWithWildCards(tuple); - int save = PROTECT(components); - TpmcPatternValue *patternValue = newTpmcPatternValue_Tuple(components); - PROTECT(patternValue); - TpmcPattern *replacement = newTpmcPattern(patternValue); - replacement->path = pattern->path; - UNPROTECT(save); - return replacement; - } else { - return pattern; - } + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + TpmcConstructorPattern *constructor = pattern->pattern->val.constructor; + if (constructor->components->size > 0) { + TpmcPatternArray *components = + replaceComponentsWithWildCards(constructor->components); + int save = PROTECT(components); + TpmcConstructorPattern *newCons = newTpmcConstructorPattern( + constructor->tag, constructor->nameSpace, constructor->info, + components); + PROTECT(newCons); + TpmcPatternValue *patternValue = + newTpmcPatternValue_Constructor(newCons); + PROTECT(patternValue); + TpmcPattern *replacement = newTpmcPattern(patternValue); + replacement->path = pattern->path; + UNPROTECT(save); + return replacement; + } else { + return pattern; } - default: + } + case TPMCPATTERNVALUE_TYPE_TUPLE: { + TpmcPatternArray *tuple = pattern->pattern->val.tuple; + if (tuple->size > 0) { + TpmcPatternArray *components = + replaceComponentsWithWildCards(tuple); + int save = PROTECT(components); + TpmcPatternValue *patternValue = + newTpmcPatternValue_Tuple(components); + PROTECT(patternValue); + TpmcPattern *replacement = newTpmcPattern(patternValue); + replacement->path = pattern->path; + UNPROTECT(save); + return replacement; + } else { return pattern; + } + } + default: + return pattern; } } -static TpmcIntArray *makeTpmcIntArray(int size, int initialValue) { - TpmcIntArray *res = newTpmcIntArray(); +static IntArray *makeIntArray(int size, int initialValue) { + IntArray *res = newIntArray(); int save = PROTECT(res); for (int i = 0; i < size; ++i) { - pushTpmcIntArray(res, initialValue); + pushIntArray(res, initialValue); } UNPROTECT(save); return res; } +// ============================================================================ +// Exhaustiveness Checking +// ============================================================================ + static bool arcsAreExhaustive(int size, TpmcArcArray *arcs, ParserInfo I) { - TpmcIntArray *flags = makeTpmcIntArray(size, 0); + IntArray *flags = makeIntArray(size, 0); int save = PROTECT(flags); for (Index i = 0; i < arcs->size; ++i) { TpmcArc *arc = arcs->entries[i]; TpmcPattern *pattern = arc->test; switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { - LamTypeConstructorInfo *info = - pattern->pattern->val.constructor->info; - if (info->index >= size) { - cant_happen("arcsAreExhaustive given constructor %s with out-of-range index (%d >= %d) while parsing %s, line %d", info->name->name, info->index, size, I.fileName, I.lineNo); - } - flags->entries[info->index] = 1; - } - break; - case TPMCPATTERNVALUE_TYPE_TUPLE: { - // tuples are exhaustive - UNPROTECT(save); - return true; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + LamTypeConstructorInfo *info = + pattern->pattern->val.constructor->info; + if (info->index >= size) { + cant_happen( + "arcsAreExhaustive given constructor %s with out-of-range " + "index (%d >= %d) while parsing %s, line %d", + info->name->name, info->index, size, I.fileName, I.lineNo); } + flags->entries[info->index] = 1; + } break; + case TPMCPATTERNVALUE_TYPE_TUPLE: { + // tuples are exhaustive + UNPROTECT(save); + return true; + } break; + case TPMCPATTERNVALUE_TYPE_COMPARISON: + // Comparison arcs don't contribute to constructor exhaustiveness - + // they're guards on already-matched values, not constructor cases. + // Skip them in the exhaustiveness check. break; - default: - cant_happen("arcsAreExhaustive given non-constructor arc while parsing %s, line %d", I.fileName, I.lineNo); + default: + cant_happen("arcsAreExhaustive given non-constructor arc while " + "parsing %s, line %d", + I.fileName, I.lineNo); } } bool res = true; @@ -515,8 +625,9 @@ static bool constructorsAreExhaustive(TpmcState *state, ParserInfo I) { } TpmcPattern *pattern = testState->arcs->entries[0]->test; if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_WILDCARD) { - cant_happen - ("constructorsAreExhaustive() passed a test state with wildCards while parsing %s, line %d", I.fileName, I.lineNo); + cant_happen("constructorsAreExhaustive() passed a test state with " + "wildCards while parsing %s, line %d", + I.fileName, I.lineNo); } else if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { int size = pattern->pattern->val.constructor->info->size; return arcsAreExhaustive(size, testState->arcs, I); @@ -550,8 +661,9 @@ static TpmcState *deduplicateState(TpmcState *state, return existing; } } - - // Not in hash table, do full linear search (for states with different stamps but same structure) + + // Not in hash table, do full linear search (for states with different + // stamps but same structure) for (Index i = 0; i < knownStates->size; i++) { if (tpmcStateEq(state, knownStates->entries[i])) { validateLastAlloc(); @@ -560,7 +672,7 @@ static TpmcState *deduplicateState(TpmcState *state, return knownStates->entries[i]; } } - + // New state, add to both array and hash table pushTpmcStateArray(knownStates, state); setTpmcStateTable(stateTable, key, state); @@ -568,49 +680,50 @@ static TpmcState *deduplicateState(TpmcState *state, } static void collectPathsBoundByConstructor(TpmcPatternArray *components, - TpmcVariableTable *boundVariables) -{ + SymbolSet *boundVariables) { for (Index i = 0; i < components->size; ++i) { TpmcPattern *pattern = components->entries[i]; - setTpmcVariableTable(boundVariables, pattern->path); + setSymbolSet(boundVariables, pattern->path); } } static void collectPathsBoundByPattern(TpmcPattern *pattern, - TpmcVariableTable *boundVariables) { + SymbolSet *boundVariables) { // FIXME is this correct? - setTpmcVariableTable(boundVariables, pattern->path); + setSymbolSet(boundVariables, pattern->path); switch (pattern->pattern->type) { - case TPMCPATTERNVALUE_TYPE_VAR: - cant_happen("collectPathsBoundByPattern encountered VAR"); - case TPMCPATTERNVALUE_TYPE_COMPARISON: - break; - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - cant_happen("collectPathsBoundByPattern encountered ASSIGNMENT"); - case TPMCPATTERNVALUE_TYPE_WILDCARD: - case TPMCPATTERNVALUE_TYPE_CHARACTER: - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - break; - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ - TpmcPatternArray *components = - pattern->pattern->val.constructor->components; - collectPathsBoundByConstructor(components, boundVariables); - } - break; - case TPMCPATTERNVALUE_TYPE_TUPLE:{ - TpmcPatternArray *components = pattern->pattern->val.tuple; - collectPathsBoundByConstructor(components, boundVariables); - } - break; - default: - cant_happen("unrecognised type %s", - tpmcPatternValueTypeName(pattern->pattern->type)); + case TPMCPATTERNVALUE_TYPE_VAR: + cant_happen("collectPathsBoundByPattern encountered VAR"); + case TPMCPATTERNVALUE_TYPE_COMPARISON: + break; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + cant_happen("collectPathsBoundByPattern encountered ASSIGNMENT"); + case TPMCPATTERNVALUE_TYPE_WILDCARD: + case TPMCPATTERNVALUE_TYPE_CHARACTER: + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + break; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + TpmcPatternArray *components = + pattern->pattern->val.constructor->components; + collectPathsBoundByConstructor(components, boundVariables); + } break; + case TPMCPATTERNVALUE_TYPE_TUPLE: { + TpmcPatternArray *components = pattern->pattern->val.tuple; + collectPathsBoundByConstructor(components, boundVariables); + } break; + default: + cant_happen("unrecognised type %s", + tpmcPatternValueTypeName(pattern->pattern->type)); } } -static TpmcVariableTable *variablesBoundByPattern(TpmcPattern *pattern) { +// ============================================================================ +// State Construction & Free Variables +// ============================================================================ + +static SymbolSet *variablesBoundByPattern(TpmcPattern *pattern) { ENTER(variablesBoundByPattern); - TpmcVariableTable *boundVariables = newTpmcVariableTable(); + SymbolSet *boundVariables = newSymbolSet(); int save = PROTECT(boundVariables); collectPathsBoundByPattern(pattern, boundVariables); LEAVE(variablesBoundByPattern); @@ -618,56 +731,68 @@ static TpmcVariableTable *variablesBoundByPattern(TpmcPattern *pattern) { return boundVariables; } -static TpmcVariableTable *getTestStatesFreeVariables(TpmcTestState *testState) { +static SymbolSet *getTestStatesFreeVariables(TpmcTestState *testState) { // The free variables of a test state is the union of the free variables // of the outgoing arcs, plus the test variable. - TpmcVariableTable *freeVariables = newTpmcVariableTable(); + SymbolSet *freeVariables = newSymbolSet(); int save = PROTECT(freeVariables); - setTpmcVariableTable(freeVariables, testState->path); + setSymbolSet(freeVariables, testState->path); for (Index i = 0; i < testState->arcs->size; ++i) { TpmcArc *arc = testState->arcs->entries[i]; if (arc->freeVariables == NULL) { - cant_happen - ("getTestStatesFreeVariables encountered arc wil null free variables"); + cant_happen("getTestStatesFreeVariables encountered arc wil null " + "free variables"); } Index i = 0; HashSymbol *key; - while ((key = - iterateTpmcVariableTable(arc->freeVariables, &i)) != NULL) { - setTpmcVariableTable(freeVariables, key); + while ((key = iterateSymbolSet(arc->freeVariables, &i)) != NULL) { + setSymbolSet(freeVariables, key); } } UNPROTECT(save); return freeVariables; } -static TpmcVariableTable *getStatesFreeVariables(TpmcState *state) { +static SymbolSet *getStatesFreeVariables(TpmcState *state) { if (state->freeVariables == NULL) { switch (state->state->type) { - case TPMCSTATEVALUE_TYPE_TEST: - state->freeVariables = - getTestStatesFreeVariables(state->state->val.test); - break; - case TPMCSTATEVALUE_TYPE_FINAL: - cant_happen - ("getStatesFreeVariables encountered final state with null free variables"); - case TPMCSTATEVALUE_TYPE_ERROR: - cant_happen - ("getStatesFreeVariables encountered error state with null free variables"); - default: - cant_happen - ("unrecognised state type %s in getStateFreeVariables", - tpmcStateValueTypeName(state->state->type)); + case TPMCSTATEVALUE_TYPE_TEST: + state->freeVariables = + getTestStatesFreeVariables(state->state->val.test); + break; + case TPMCSTATEVALUE_TYPE_FINAL: + cant_happen("getStatesFreeVariables encountered final state with " + "null free variables"); + case TPMCSTATEVALUE_TYPE_ERROR: + cant_happen("getStatesFreeVariables encountered error state with " + "null free variables"); + default: + cant_happen("unrecognised state type %s in getStateFreeVariables", + tpmcStateValueTypeName(state->state->type)); } } return state->freeVariables; } -static void addFreeVariablesRequiredByPattern(TpmcPattern *pattern, TpmcVariableTable *freeVariables) { +// Check if pathA is an ancestor of pathB (pathB starts with pathA$) +static bool isAncestorPath(HashSymbol *pathA, HashSymbol *pathB) { + const char *a = pathA->name; + const char *b = pathB->name; + size_t lenA = strlen(a); + // pathB must start with pathA followed by '$' + return strncmp(a, b, lenA) == 0 && b[lenA] == '$'; +} + +static void addFreeVariablesRequiredByPattern(TpmcPattern *pattern, + SymbolSet *freeVariables) { if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON) { TpmcPattern *previous = pattern->pattern->val.comparison->previous; HashSymbol *name = previous->path; - setTpmcVariableTable(freeVariables, name); + // Only add as free variable if previous is NOT an ancestor of current + // If previous is an ancestor, it will be bound during descent + if (!isAncestorPath(name, pattern->path)) { + setSymbolSet(freeVariables, name); + } } } @@ -678,17 +803,18 @@ static TpmcArc *makeTpmcArc(TpmcPattern *pattern, TpmcState *state) { PROTECT(state); TpmcArc *arc = newTpmcArc(state, pattern); PROTECT(arc); - // the free variables of an arc are the free variables of its state minus the variables bound in the pattern - TpmcVariableTable *boundVariables = variablesBoundByPattern(pattern); + // the free variables of an arc are the free variables of its state minus + // the variables bound in the pattern + SymbolSet *boundVariables = variablesBoundByPattern(pattern); PROTECT(boundVariables); validateLastAlloc(); - TpmcVariableTable *statesFreeVariables = getStatesFreeVariables(state); + SymbolSet *statesFreeVariables = getStatesFreeVariables(state); PROTECT(statesFreeVariables); Index i = 0; HashSymbol *key; - while ((key = iterateTpmcVariableTable(statesFreeVariables, &i)) != NULL) { - if (!getTpmcVariableTable(boundVariables, key)) { - setTpmcVariableTable(arc->freeVariables, key); + while ((key = iterateSymbolSet(statesFreeVariables, &i)) != NULL) { + if (!getSymbolSet(boundVariables, key)) { + setSymbolSet(arc->freeVariables, key); } } addFreeVariablesRequiredByPattern(pattern, arc->freeVariables); @@ -698,133 +824,194 @@ static TpmcArc *makeTpmcArc(TpmcPattern *pattern, TpmcState *state) { return arc; } -static TpmcIntArray *findWcIndices(TpmcPatternArray *N) { - TpmcIntArray *wcIndices = newTpmcIntArray(); +// Find indices of rows that should be treated as wildcards for the default arc. +// This includes actual wildcards AND non-ready comparisons (comparisons whose +// required path is not yet a column header or in testedPaths). +static IntArray *findWcIndices(TpmcPatternArray *selectedColumn, + TpmcMatrix *matrix, SymbolSet *testedPaths) { + IntArray *wcIndices = newIntArray(); int save = PROTECT(wcIndices); Index row = 0; TpmcPattern *candidate; - while (iterateTpmcPatternArray(N, &row, &candidate, NULL)) { + while (iterateTpmcPatternArray(selectedColumn, &row, &candidate, NULL)) { + // Include actual wildcards if (patternIsWildCard(candidate)) { - pushTpmcIntArray(wcIndices, row - 1); + pushIntArray(wcIndices, row - 1); + } + // Also include non-ready comparisons (they were skipped in arc + // creation) + else if (patternIsComparison(candidate) && + !comparisonIsReady(candidate, matrix, testedPaths)) { + pushIntArray(wcIndices, row - 1); } } UNPROTECT(save); return wcIndices; } -static TpmcState *mixture(TpmcMatrix *M, TpmcStateArray *finalStates, - TpmcState *errorState, TpmcStateArray *knownStates, - TpmcStateTable *stateTable, bool *unsafe, ParserInfo I) { - ENTER(mixture); - // there is some column N whose topmost pattern is a constructor - int firstConstructorColumn = findFirstConstructorColumn(M); - // this heuristic allows for comparisons to work: - if (firstConstructorColumn > 0 && columnHasComparisons(firstConstructorColumn, M)) { - firstConstructorColumn = 0; - } - TpmcPatternArray *N = extractMatrixColumn(firstConstructorColumn, M); - int save = PROTECT(N); - // let M-N be all the columns in M except N - TpmcMatrix *MN = discardMatrixColumn(firstConstructorColumn, M); - PROTECT(MN); - // The goal is to build a test state with the variable v and some outgoing arcs - // (one for each constructor and possibly a default arc). - TpmcState *testState = makeEmptyTestState(N->entries[0]->path); - PROTECT(testState); - for (Index row = 0; row < N->size; row++) { - TpmcPattern *c = N->entries[row]; - // For each constructor c in the selected column, its arc is defined as follows: - if (!patternIsWildCard(c)) { - // Skip if we've already added an arc for this exact constructor pattern - // This prevents redundant recursive match() calls for duplicate constructors - bool alreadyProcessed = false; - for (Index i = 0; i < testState->state->val.test->arcs->size; i++) { - TpmcArc *existingArc = testState->state->val.test->arcs->entries[i]; - // Check if the constructor pattern matches (not the full arc, just the pattern) - if (c->pattern->type == existingArc->test->pattern->type) { - if (c->pattern->type == TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { - if (c->pattern->val.constructor->tag == existingArc->test->pattern->val.constructor->tag) { - alreadyProcessed = true; - break; - } - } else if (c->pattern->type == TPMCPATTERNVALUE_TYPE_CHARACTER) { - if (c->pattern->val.character == existingArc->test->pattern->val.character) { - alreadyProcessed = true; - break; - } - } else if (c->pattern->type == TPMCPATTERNVALUE_TYPE_BIGINTEGER) { - if (cmpMaybeBigInt(c->pattern->val.bigInteger, existingArc->test->pattern->val.bigInteger) == 0) { - alreadyProcessed = true; - break; - } - } else if (c->pattern->type == TPMCPATTERNVALUE_TYPE_TUPLE) { - // All tuples of same arity are considered the same constructor - alreadyProcessed = true; - break; - } else if (c->pattern->type == TPMCPATTERNVALUE_TYPE_COMPARISON) { - // Comparisons might be unique, check deeper - if (tpmcPatternEq(c, existingArc->test)) { - alreadyProcessed = true; - break; - } - } - } +// Check if an arc for this pattern already exists in the test state. +// Returns true if we've already added an arc for this exact constructor/literal +// pattern, which prevents redundant recursive match() calls for duplicates. +static bool arcExistsForPattern(TpmcPattern *pattern, TpmcState *testState) { + TpmcArcArray *arcs = testState->state->val.test->arcs; + for (Index i = 0; i < arcs->size; i++) { + TpmcArc *existingArc = arcs->entries[i]; + // Must be same pattern type + if (pattern->pattern->type != existingArc->test->pattern->type) { + continue; + } + switch (pattern->pattern->type) { + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + if (pattern->pattern->val.constructor->tag == + existingArc->test->pattern->val.constructor->tag) { + return true; + } + break; + case TPMCPATTERNVALUE_TYPE_CHARACTER: + if (pattern->pattern->val.character == + existingArc->test->pattern->val.character) { + return true; + } + break; + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + if (cmpMaybeBigInt(pattern->pattern->val.bigInteger, + existingArc->test->pattern->val.bigInteger) == + 0) { + return true; + } + break; + case TPMCPATTERNVALUE_TYPE_TUPLE: + // All tuples of same arity are considered the same constructor + return true; + case TPMCPATTERNVALUE_TYPE_COMPARISON: + // Comparisons might be unique, check deeper + if (tpmcPatternEq(pattern, existingArc->test)) { + return true; } - if (alreadyProcessed) { + break; + default: + // Wildcards and other types don't create arcs + break; + } + } + return false; +} + +// ============================================================================ +// Mixture Algorithm - Arc Construction +// ============================================================================ + +// Build arcs for each unique constructor/literal in the selected column. +// For each pattern, creates a sub-matrix by extracting matching rows, +// recursively calls match(), and adds the resulting arc to the test state. +static void buildConstructorArcs( + TpmcPatternArray *selectedColumn, TpmcMatrix *remainingColumns, + TpmcMatrix *matrix, TpmcStateArray *finalStates, TpmcState *errorState, + TpmcStateArray *knownStates, TpmcStateTable *stateTable, + TpmcState *testState, bool *unsafe, SymbolSet *testedPaths, ParserInfo I) { + for (Index row = 0; row < selectedColumn->size; row++) { + TpmcPattern *currentPattern = selectedColumn->entries[row]; + // For each constructor in the selected column, its arc is defined as + // follows: + // Skip wildcards AND non-ready comparisons (comparisons whose required + // path is not yet a column header). Non-ready comparisons are handled + // via the wildcard/default arc path instead. + if (patternIsActionable(currentPattern, matrix, testedPaths)) { + // Skip if we've already added an arc for this exact constructor + // pattern. This prevents redundant recursive match() calls for + // duplicate constructors. + if (arcExistsForPattern(currentPattern, testState)) { continue; } - // Let {i1 , ... , ij} be the row-indices of the patterns in N that match c. - TpmcIntArray *indicesMatchingC = findPatternsMatching(c, N); - int save2 = PROTECT(indicesMatchingC); - // Let {pat1 , ... , patj} be the patterns in the column corresponding to the indices computed above, - TpmcPatternArray *patternsMatchingC = extractColumnSubset(indicesMatchingC, N); - PROTECT(patternsMatchingC); - // let n be the arity of the constructor c - int n = arityOf(c); + // Let {i1 , ... , ij} be the row-indices of the patterns in + // selectedColumn that match currentPattern. + IntArray *matchingIndices = + findPatternsMatching(currentPattern, selectedColumn); + int save2 = PROTECT(matchingIndices); + // Let {pat1 , ... , patj} be the patterns in the column + // corresponding to the indices computed above, + TpmcPatternArray *matchingPatterns = + extractColumnSubset(matchingIndices, selectedColumn); + PROTECT(matchingPatterns); + // let arity be the arity of the constructor + int arity = arityOf(currentPattern); // For each pati, its n sub-patterns are extracted; - // if pati is a wildCard, n wildCards are produced instead, each tagged with the right path variable. - TpmcMatrix *subPatternsMatchingC = makeSubPatternMatrix(patternsMatchingC, n, I); - PROTECT(subPatternsMatchingC); - // This matrix is then appended to the result of selecting, from each column in MN, - // those rows whose indices are in {i1 , ... , ij}. - TpmcMatrix *prefixMatrix = extractMatrixRows(indicesMatchingC, MN); + // if pati is a wildCard, n wildCards are produced instead, each + // tagged with the right path variable. + TpmcMatrix *subPatternMatrix = + makeSubPatternMatrix(matchingPatterns, arity, I); + PROTECT(subPatternMatrix); + // This matrix is then appended to the result of selecting, from + // each column in remainingColumns, those rows whose indices are in + // {i1 , ... , ij}. + TpmcMatrix *prefixMatrix = + extractMatrixRows(matchingIndices, remainingColumns); PROTECT(prefixMatrix); - TpmcMatrix *newMatrix = appendMatrices(prefixMatrix, subPatternsMatchingC); + TpmcMatrix *newMatrix = + appendMatrices(prefixMatrix, subPatternMatrix); PROTECT(newMatrix); - // Finally the indices are used to select the corresponding final states that go with these rows. - TpmcStateArray *newFinalStates = extractStateArraySubset(indicesMatchingC, finalStates); + // Finally the indices are used to select the corresponding final + // states that go with these rows. + TpmcStateArray *newFinalStates = + extractStateArraySubset(matchingIndices, finalStates); PROTECT(newFinalStates); - // The arc for the constructor c is now defined as (c’,state), where c’ is c with any immediate - // sub-patterns replaced by their path variables (thus c’ is a simple pattern) - TpmcPattern *cPrime = replacePatternComponentsWithWildCards(c); - PROTECT(cPrime); - // and state is the result of recursively applying match to the new matrix and the new sequence of final states - TpmcState *newState = match(newMatrix, newFinalStates, errorState, knownStates, stateTable, unsafe, I); + // The arc for the constructor is (simplifiedPattern, state), where + // simplifiedPattern is currentPattern with any immediate + // sub-patterns replaced by their path variables + TpmcPattern *simplifiedPattern = + replacePatternComponentsWithWildCards(currentPattern); + PROTECT(simplifiedPattern); + // and state is the result of recursively applying match to the new + // matrix and the new sequence of final states + TpmcState *newState = + match(newMatrix, newFinalStates, errorState, knownStates, + stateTable, unsafe, testedPaths, I); PROTECT(newState); - TpmcArc *arc = makeTpmcArc(cPrime, newState); + TpmcArc *arc = makeTpmcArc(simplifiedPattern, newState); PROTECT(arc); - // Add the arc (duplicate constructors are now filtered earlier in the loop) + // Add the arc (duplicate constructors are now filtered earlier in + // the loop) pushTpmcArcArray(testState->state->val.test->arcs, arc); UNPROTECT(save2); } } +} + +// Build the default (wildcard) arc or error arc if constructors aren't +// exhaustive. Handles rows that match wildcards or non-ready comparisons. +static void buildDefaultArc(TpmcPatternArray *selectedColumn, + TpmcMatrix *remainingColumns, TpmcMatrix *matrix, + TpmcStateArray *finalStates, TpmcState *errorState, + TpmcStateArray *knownStates, + TpmcStateTable *stateTable, TpmcState *testState, + bool *unsafe, SymbolSet *testedPaths, + ParserInfo I) { // Finally, the possibility for matching failure is considered. // If the set of constructors is exhaustive, then no more arcs are computed if (!constructorsAreExhaustive(testState, I)) { // Otherwise, a default arc (_,state) is the last arc. - // If there are any wildCard patterns in the selected column - TpmcIntArray *wcIndices = findWcIndices(N); + // If there are any wildCard patterns (or non-ready comparisons) in the + // selected column + IntArray *wcIndices = + findWcIndices(selectedColumn, matrix, testedPaths); PROTECT(wcIndices); - if (countTpmcIntArray(wcIndices) > 0) { - // then their rows are selected from the rest of the matrix and the final states - TpmcMatrix *wcMatrix = extractMatrixRows(wcIndices, MN); + if (countIntArray(wcIndices) > 0) { + // then their rows are selected from the rest of the matrix and the + // final states + TpmcMatrix *wcMatrix = + extractMatrixRows(wcIndices, remainingColumns); PROTECT(wcMatrix); - TpmcStateArray *wcFinalStates = extractStateArraySubset(wcIndices, finalStates); + TpmcStateArray *wcFinalStates = + extractStateArraySubset(wcIndices, finalStates); PROTECT(wcFinalStates); - // and the state is the result of applying match to the new matrix and states - TpmcState *wcState = match(wcMatrix, wcFinalStates, errorState, knownStates, stateTable, unsafe, I); + // and the state is the result of applying match to the new matrix + // and states + TpmcState *wcState = + match(wcMatrix, wcFinalStates, errorState, knownStates, + stateTable, unsafe, testedPaths, I); PROTECT(wcState); - TpmcPattern *wcPattern = makeNamedWildCardPattern(N->entries[0]->path); + TpmcPattern *wcPattern = + makeNamedWildCardPattern(selectedColumn->entries[0]->path); PROTECT(wcPattern); TpmcArc *wcArc = makeTpmcArc(wcPattern, wcState); PROTECT(wcArc); @@ -832,23 +1019,67 @@ static TpmcState *mixture(TpmcMatrix *M, TpmcStateArray *finalStates, } else { validateLastAlloc(); *unsafe = true; - // Otherwise, the error state is used after its reference count has been incremented - TpmcPattern *errorPattern = makeNamedWildCardPattern(N->entries[0]->path); + // Otherwise, the error state is used after its reference count has + // been incremented + TpmcPattern *errorPattern = + makeNamedWildCardPattern(selectedColumn->entries[0]->path); PROTECT(errorPattern); TpmcArc *errorArc = makeTpmcArc(errorPattern, errorState); PROTECT(errorArc); pushTpmcArcArray(testState->state->val.test->arcs, errorArc); } } +} + +static TpmcState *mixture(TpmcMatrix *matrix, TpmcStateArray *finalStates, + TpmcState *errorState, TpmcStateArray *knownStates, + TpmcStateTable *stateTable, bool *unsafe, + SymbolSet *testedPaths, ParserInfo I) { + ENTER(mixture); + // Find first column with an actionable pattern (constructor, literal, or + // ready comparison). Non-ready comparisons are treated as wildcards until + // their required bindings are available. + int firstConstructorColumn = findFirstActionableColumn(matrix, testedPaths); + TpmcPatternArray *selectedColumn = + extractMatrixColumn(firstConstructorColumn, matrix); + int save = PROTECT(selectedColumn); + // remainingColumns is all the columns in matrix except selectedColumn + TpmcMatrix *remainingColumns = + discardMatrixColumn(firstConstructorColumn, matrix); + PROTECT(remainingColumns); + // Build a test state with the variable v and some outgoing arcs + // (one for each constructor and possibly a default arc). + TpmcState *testState = makeEmptyTestState(selectedColumn->entries[0]->path); + PROTECT(testState); + // Add the tested column path to testedPaths for recursive calls. + // This ensures comparisons requiring this path will be considered ready. + HashSymbol *testedPath = selectedColumn->entries[0]->path; + setSymbolSet(testedPaths, testedPath); + + // Build arcs for each unique constructor/literal + buildConstructorArcs(selectedColumn, remainingColumns, matrix, finalStates, + errorState, knownStates, stateTable, testState, unsafe, + testedPaths, I); + + // Build default/error arc if needed + buildDefaultArc(selectedColumn, remainingColumns, matrix, finalStates, + errorState, knownStates, stateTable, testState, unsafe, + testedPaths, I); + TpmcState *res = deduplicateState(testState, knownStates, stateTable); UNPROTECT(save); LEAVE(mixture); return res; } +// ============================================================================ +// Main Match Algorithm +// ============================================================================ + static TpmcState *match(TpmcMatrix *matrix, TpmcStateArray *finalStates, TpmcState *errorState, TpmcStateArray *knownStates, - TpmcStateTable *stateTable, bool *unsafe, ParserInfo I) { + TpmcStateTable *stateTable, bool *unsafe, + SymbolSet *testedPaths, ParserInfo I) { ENTER(match); // IFDEBUG(ppTpmcMatrix(matrix)); // IFDEBUG(ppTpmcStateArray(finalStates)); @@ -856,10 +1087,11 @@ static TpmcState *match(TpmcMatrix *matrix, TpmcStateArray *finalStates, cant_happen("zero-height matrix passed to match"); } TpmcState *res = NULL; - if (topRowOnlyVariables(matrix)) { + if (topRowHasNoActionablePatterns(matrix, testedPaths)) { res = finalStates->entries[0]; } else { - res = mixture(matrix, finalStates, errorState, knownStates, stateTable, unsafe, I); + res = mixture(matrix, finalStates, errorState, knownStates, stateTable, + unsafe, testedPaths, I); } IFDEBUG(ppTpmcState(res)); LEAVE(match); diff --git a/src/tpmc_mermaid.c b/src/tpmc_mermaid.c index 1e1737ad..1382cc72 100644 --- a/src/tpmc_mermaid.c +++ b/src/tpmc_mermaid.c @@ -15,48 +15,37 @@ * You should have received a copy of the GNU General Public License * along with this program. If not, see . */ -#include -#include +#include "tpmc_mermaid.h" #include "common.h" #include "symbol.h" -#include "tpmc_mermaid.h" +#include "utils.h" +#include +#include int tpmc_mermaid_flag = 0; char *tpmc_mermaid_function = NULL; -static char *mermaidState(TpmcState *state); +static SCharVec *mermaidState(TpmcState *state, SymbolSet *seen); static void mermaidPattern(TpmcPattern *pattern); -static TpmcVariableTable *seen = NULL; - -static int initSeenTable() { - seen = newTpmcVariableTable(); - return PROTECT(seen); -} - -static void terminateSeenTable(int save) { - UNPROTECT(save); - seen = NULL; -} - -static bool seenName(char *name) { +static bool seenName(char *name, SymbolSet *seen) { HashSymbol *symbol = newSymbol(name); - if (getTpmcVariableTable(seen, symbol)) + if (getSymbolSet(seen, symbol)) return true; - setTpmcVariableTable(seen, symbol); + setSymbolSet(seen, symbol); return false; } -static void mermaidFreeVariables(TpmcVariableTable *freeVariables) { +static void mermaidFreeVariables(SymbolSet *freeVariables) { printf("["); if (freeVariables != NULL) { Index i = 0; Index count = 0; HashSymbol *key; - while ((key = iterateTpmcVariableTable(freeVariables, &i)) != NULL) { + while ((key = iterateSymbolSet(freeVariables, &i)) != NULL) { printf("%s", key->name); count++; - if (count < countTpmcVariableTable(freeVariables)) { + if (count < countSymbolSet(freeVariables)) { printf(" "); } } @@ -64,37 +53,37 @@ static void mermaidFreeVariables(TpmcVariableTable *freeVariables) { printf("]"); } -static char *mermaidStateName(TpmcState *state) { +static SCharVec *mermaidStateName(TpmcState *state, SymbolSet *seen) { static char buf[512]; switch (state->state->type) { - case TPMCSTATEVALUE_TYPE_TEST: - sprintf(buf, "T%d", state->stamp); - if (!seenName(buf)) { - printf("%s(\"%s\\n", buf, - state->state->val.test->path->name); - mermaidFreeVariables(state->freeVariables); - printf("\\n(arcs %d)\")\n", countTpmcArcArray(state->state->val.test->arcs)); - } - break; - case TPMCSTATEVALUE_TYPE_FINAL: - sprintf(buf, "F%d", state->stamp); - if (!seenName(buf)) { - printf("%s(\"", buf); - ppLamExp(state->state->val.final->action); - printf("\\n"); - mermaidFreeVariables(state->freeVariables); - printf("\")\n"); - } - break; - case TPMCSTATEVALUE_TYPE_ERROR: - sprintf(buf, "ERROR"); - printf("%s\n", buf); - break; - default: - cant_happen("unrecognised statevalue type %d in mermaidStateName", - state->state->type); + case TPMCSTATEVALUE_TYPE_TEST: + sprintf(buf, "T%d", state->stamp); + if (!seenName(buf, seen)) { + printf("%s(\"%s
", buf, state->state->val.test->path->name); + mermaidFreeVariables(state->freeVariables); + printf("
(arcs %d)\")\n", + countTpmcArcArray(state->state->val.test->arcs)); + } + break; + case TPMCSTATEVALUE_TYPE_FINAL: + sprintf(buf, "F%d", state->stamp); + if (!seenName(buf, seen)) { + printf("%s(\"", buf); + ppLamExp(state->state->val.final->action); + printf("
"); + mermaidFreeVariables(state->freeVariables); + printf("\")\n"); + } + break; + case TPMCSTATEVALUE_TYPE_ERROR: + sprintf(buf, "ERROR"); + printf("%s\n", buf); + break; + default: + cant_happen("unrecognised statevalue type %d in mermaidStateName", + state->state->type); } - return strdup(buf); + return stringToSCharVec(buf); } static void mermaidConstructorComponents(TpmcPatternArray *patterns) { @@ -110,98 +99,106 @@ static void mermaidPattern(TpmcPattern *pattern) { printf("%s:", pattern->path->name); TpmcPatternValue *value = pattern->pattern; switch (value->type) { - case TPMCPATTERNVALUE_TYPE_VAR: - printf("var %s", value->val.var->name); - break; - case TPMCPATTERNVALUE_TYPE_COMPARISON: - mermaidPattern(value->val.comparison->previous); - printf("=="); - mermaidPattern(value->val.comparison->current); - break; - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - printf("assignment"); - break; - case TPMCPATTERNVALUE_TYPE_WILDCARD: - printf("_"); - break; - case TPMCPATTERNVALUE_TYPE_CHARACTER: - printf("'%c'", value->val.character); - break; - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - fprintMaybeBigInt(stdout, value->val.bigInteger); - break; - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - printf("%s(", value->val.constructor->tag->name); - mermaidConstructorComponents(value->val.constructor->components); - printf(")"); - break; - case TPMCPATTERNVALUE_TYPE_TUPLE: - printf("#("); - mermaidConstructorComponents(value->val.tuple); - printf(")"); - break; - default: - cant_happen("unrecognised type %s", tpmcPatternValueTypeName(value->type)); + case TPMCPATTERNVALUE_TYPE_VAR: + printf("var %s", value->val.var->name); + break; + case TPMCPATTERNVALUE_TYPE_COMPARISON: + mermaidPattern(value->val.comparison->previous); + printf("=="); + mermaidPattern(value->val.comparison->current); + break; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + printf("assignment"); + break; + case TPMCPATTERNVALUE_TYPE_WILDCARD: + printf("_"); + break; + case TPMCPATTERNVALUE_TYPE_CHARACTER: + printf("'%c'", value->val.character); + break; + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + fprintMaybeBigInt(stdout, value->val.bigInteger); + break; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + printf("%s(", value->val.constructor->tag->name); + mermaidConstructorComponents(value->val.constructor->components); + printf(")"); + break; + case TPMCPATTERNVALUE_TYPE_TUPLE: + printf("#("); + mermaidConstructorComponents(value->val.tuple); + printf(")"); + break; + default: + cant_happen("unrecognised type %s", + tpmcPatternValueTypeName(value->type)); } } static void mermaidArcLabel(TpmcArc *arc) { printf("\""); mermaidPattern(arc->test); - printf("\\n"); + printf("
"); mermaidFreeVariables(arc->freeVariables); printf("\""); } -static void mermaidArc(char *stateName, TpmcArc *arc) { - char *targetState = mermaidState(arc->state); - printf("%s --", stateName); +static void mermaidArc(SCharVec *stateName, TpmcArc *arc, SymbolSet *seen) { + SCharVec *targetState = mermaidState(arc->state, seen); + int save = PROTECT(targetState); + printf("%s --", stateName->entries); mermaidArcLabel(arc); - printf("--> %s\n", targetState); - free(targetState); + printf("--> %s\n", targetState->entries); + UNPROTECT(save); } -static void mermaidTestState(char *name, TpmcTestState *testState) { +static void mermaidTestState(SCharVec *name, TpmcTestState *testState, + SymbolSet *seen) { for (Index i = 0; i < countTpmcArcArray(testState->arcs); i++) { - mermaidArc(name, testState->arcs->entries[i]); + mermaidArc(name, testState->arcs->entries[i], seen); } } -static void mermaidStateValue(char *name, TpmcStateValue *value) { +static void mermaidStateValue(SCharVec *name, TpmcStateValue *value, + SymbolSet *seen) { if (value == NULL) { return; } switch (value->type) { - case TPMCSTATEVALUE_TYPE_TEST: - mermaidTestState(name, value->val.test); - break; - case TPMCSTATEVALUE_TYPE_FINAL: - case TPMCSTATEVALUE_TYPE_ERROR: - break; - default: - cant_happen - ("unrecognised statevalue type %d in mermaidStateValue", - value->type); + case TPMCSTATEVALUE_TYPE_TEST: + mermaidTestState(name, value->val.test, seen); + break; + case TPMCSTATEVALUE_TYPE_FINAL: + case TPMCSTATEVALUE_TYPE_ERROR: + break; + default: + cant_happen("unrecognised statevalue type %d in mermaidStateValue", + value->type); } } -static char *mermaidState(TpmcState *state) { +static SCharVec *mermaidState(TpmcState *state, SymbolSet *seen) { if (state == NULL) { - return ""; + return stringToSCharVec(""); } - char *name = mermaidStateName(state); - mermaidStateValue(name, state->state); + SCharVec *name = mermaidStateName(state, seen); + int save = PROTECT(name); + mermaidStateValue(name, state->state, seen); + UNPROTECT(save); return name; } void tpmcMermaid(TpmcState *state) { if (tpmc_mermaid_flag) { - int save = initSeenTable(); - printf("## %s\n", tpmc_mermaid_function); + SymbolSet *seen = newSymbolSet(); + int save = PROTECT(seen); printf("```mermaid\n"); - printf("flowchart TD\n"); - free(mermaidState(state)); + printf("---\n"); + printf("title: %s\n", tpmc_mermaid_function); + printf("---\n"); + printf("flowchart LR\n"); + mermaidState(state, seen); printf("```\n"); - terminateSeenTable(save); + UNPROTECT(save); } } diff --git a/src/tpmc_pp.c b/src/tpmc_pp.c index 2a23f8ab..6645c98a 100644 --- a/src/tpmc_pp.c +++ b/src/tpmc_pp.c @@ -61,30 +61,30 @@ void ppTpmcPatternValue(TpmcPatternValue *patternValue) { return; } switch (patternValue->type) { - case TPMCPATTERNVALUE_TYPE_VAR: - ppTpmcSymbol(patternValue->val.var); - break; - case TPMCPATTERNVALUE_TYPE_COMPARISON: - ppTpmcComparisonPattern(patternValue->val.comparison); - break; - case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: - ppTpmcAssignmentPattern(patternValue->val.assignment); - break; - case TPMCPATTERNVALUE_TYPE_WILDCARD: - eprintf("_"); - break; - case TPMCPATTERNVALUE_TYPE_CHARACTER: - eprintf("'%c'", patternValue->val.character); - break; - case TPMCPATTERNVALUE_TYPE_BIGINTEGER: - fprintMaybeBigInt(errout, patternValue->val.bigInteger); - break; - case TPMCPATTERNVALUE_TYPE_TUPLE: - ppTpmcTuplePattern(patternValue->val.tuple); - break; - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - ppTpmcConstructorPattern(patternValue->val.constructor); - break; + case TPMCPATTERNVALUE_TYPE_VAR: + ppTpmcSymbol(patternValue->val.var); + break; + case TPMCPATTERNVALUE_TYPE_COMPARISON: + ppTpmcComparisonPattern(patternValue->val.comparison); + break; + case TPMCPATTERNVALUE_TYPE_ASSIGNMENT: + ppTpmcAssignmentPattern(patternValue->val.assignment); + break; + case TPMCPATTERNVALUE_TYPE_WILDCARD: + eprintf("_"); + break; + case TPMCPATTERNVALUE_TYPE_CHARACTER: + eprintf("'%c'", patternValue->val.character); + break; + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: + fprintMaybeBigInt(errout, patternValue->val.bigInteger); + break; + case TPMCPATTERNVALUE_TYPE_TUPLE: + ppTpmcTuplePattern(patternValue->val.tuple); + break; + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + ppTpmcConstructorPattern(patternValue->val.constructor); + break; } } @@ -125,14 +125,14 @@ void ppTpmcMatrix(TpmcMatrix *matrix) { static char getTpmcStateType(TpmcState *state) { switch (state->state->type) { - case TPMCSTATEVALUE_TYPE_TEST: - return 'T'; - case TPMCSTATEVALUE_TYPE_FINAL: - return 'F'; - case TPMCSTATEVALUE_TYPE_ERROR: - return 'E'; - default: - return '?'; + case TPMCSTATEVALUE_TYPE_TEST: + return 'T'; + case TPMCSTATEVALUE_TYPE_FINAL: + return 'F'; + case TPMCSTATEVALUE_TYPE_ERROR: + return 'E'; + default: + return '?'; } } @@ -144,16 +144,16 @@ void ppTpmcState(TpmcState *state) { ppTpmcStateValue(state->state); } -void ppTpmcVariableTable(TpmcVariableTable *table) { +void ppTpmcVariableTable(SymbolSet *table) { eprintf("["); if (table != NULL) { Index i = 0; Index count = 0; HashSymbol *symbol; - while ((symbol = iterateTpmcVariableTable(table, &i)) != NULL) { + while ((symbol = iterateSymbolSet(table, &i)) != NULL) { ppTpmcSymbol(symbol); count++; - if (count < countTpmcVariableTable(table)) { + if (count < countSymbolSet(table)) { eprintf(", "); } } @@ -161,21 +161,19 @@ void ppTpmcVariableTable(TpmcVariableTable *table) { eprintf("]"); } -void ppTpmcSymbol(HashSymbol *symbol) { - eprintf("%s", symbol->name); -} +void ppTpmcSymbol(HashSymbol *symbol) { eprintf("%s", symbol->name); } void ppTpmcStateValue(TpmcStateValue *value) { switch (value->type) { - case TPMCSTATEVALUE_TYPE_TEST: - ppTpmcTestState(value->val.test); - break; - case TPMCSTATEVALUE_TYPE_FINAL: - ppTpmcFinalState(value->val.final); - break; - case TPMCSTATEVALUE_TYPE_ERROR: - eprintf("ERROR"); - break; + case TPMCSTATEVALUE_TYPE_TEST: + ppTpmcTestState(value->val.test); + break; + case TPMCSTATEVALUE_TYPE_FINAL: + ppTpmcFinalState(value->val.final); + break; + case TPMCSTATEVALUE_TYPE_ERROR: + eprintf("ERROR"); + break; } } @@ -208,16 +206,14 @@ void ppTpmcArc(TpmcArc *arc) { eprintf(")"); } -void ppTpmcFinalState(TpmcFinalState *final) { - ppLamExp(final->action); -} +void ppTpmcFinalState(TpmcFinalState *final) { ppLamExp(final->action); } -void ppTpmcIntArray(TpmcIntArray *array) { +void ppTpmcIntArray(IntArray *array) { eprintf("["); Index i = 0; int entry; bool more; - while (iterateTpmcIntArray(array, &i, &entry, &more)) { + while (iterateIntArray(array, &i, &entry, &more)) { eprintf("%d%s", entry, more ? ", " : ""); } eprintf("]"); diff --git a/src/tpmc_pp.h b/src/tpmc_pp.h index 90cc5364..750c3fa8 100644 --- a/src/tpmc_pp.h +++ b/src/tpmc_pp.h @@ -1,5 +1,5 @@ #ifndef cekf_tpmc_pp_h -# define cekf_tpmc_pp_h +#define cekf_tpmc_pp_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -18,7 +18,7 @@ * along with this program. If not, see . */ -# include "tpmc.h" +#include "tpmc.h" void ppTpmcMatrix(TpmcMatrix *matrix); void ppTpmcPattern(TpmcPattern *pattern); @@ -28,14 +28,14 @@ void ppTpmcAssignmentPattern(TpmcAssignmentPattern *assignmentPattern); void ppTpmcConstructorPattern(TpmcConstructorPattern *constructorPattern); void ppTpmcPatternArray(TpmcPatternArray *patternArray); void ppTpmcState(TpmcState *state); -void ppTpmcVariableTable(TpmcVariableTable *table); +void ppTpmcVariableTable(SymbolSet *table); void ppTpmcSymbol(HashSymbol *symbol); void ppTpmcStateValue(TpmcStateValue *value); void ppTpmcTestState(TpmcTestState *test); void ppTpmcArcArray(TpmcArcArray *arcs); void ppTpmcArc(TpmcArc *arc); void ppTpmcFinalState(TpmcFinalState *final); -void ppTpmcIntArray(TpmcIntArray *array); +void ppTpmcIntArray(IntArray *array); void ppTpmcStateArray(TpmcStateArray *array); #endif diff --git a/src/tpmc_translate.c b/src/tpmc_translate.c index ab921188..d1d14228 100644 --- a/src/tpmc_translate.c +++ b/src/tpmc_translate.c @@ -18,21 +18,21 @@ * Term Pattern Matching Compiler stage 4. code generation */ -#include -#include -#include +#include "common.h" #include "lambda.h" #include "lambda_helper.h" +#include "symbol.h" #include "tpmc.h" #include "tpmc_pp.h" -#include "symbol.h" -#include "common.h" +#include +#include +#include #ifdef DEBUG_TPMC_TRANSLATE -# include "tpmc_debug.h" -# include "debugging_on.h" +#include "debugging_on.h" +#include "tpmc_debug.h" #else -# include "debugging_off.h" +#include "debugging_off.h" #endif static ParserInfo I; @@ -47,21 +47,21 @@ static HashSymbol *makeLambdaName(TpmcState *state) { return newSymbol(buf); } -static LamVarList *makeCanonicalArgs(TpmcVariableTable *freeVariables) { +static SymbolList *makeCanonicalArgs(SymbolSet *freeVariables) { ENTER(makeCanonicalArgs); - if (countTpmcVariableTable(freeVariables) == 0) { + if (countSymbolSet(freeVariables) == 0) { LEAVE(makeCanonicalArgs); return NULL; } - TpmcVariableArray *sorted = newTpmcVariableArray(); + SymbolArray *sorted = newSymbolArray(); int save = PROTECT(sorted); Index i = 0; HashSymbol *key; - while ((key = iterateTpmcVariableTable(freeVariables, &i)) != NULL) { - pushTpmcVariableArray(sorted, key); + while ((key = iterateSymbolSet(freeVariables, &i)) != NULL) { + pushSymbolArray(sorted, key); for (int i = sorted->size - 1; i > 0; i--) { - if (strcmp(sorted->entries[i - 1]->name, sorted->entries[i]->name) - > 0) { + if (strcmp(sorted->entries[i - 1]->name, sorted->entries[i]->name) > + 0) { key = sorted->entries[i]; sorted->entries[i] = sorted->entries[i - 1]; sorted->entries[i - 1] = key; @@ -72,9 +72,9 @@ static LamVarList *makeCanonicalArgs(TpmcVariableTable *freeVariables) { } // claim an extra slot int save2 = PROTECT(sorted); - LamVarList *res = NULL; + SymbolList *res = NULL; for (Index i = 0; i < sorted->size; i++) { - res = newLamVarList(I, sorted->entries[i], res); + res = newSymbolList(I, sorted->entries[i], res); REPLACE_PROTECT(save2, res); } UNPROTECT(save); @@ -82,7 +82,7 @@ static LamVarList *makeCanonicalArgs(TpmcVariableTable *freeVariables) { return res; } -static LamArgs *convertVarListToList(LamVarList *vars) { +static LamArgs *convertVarListToList(SymbolList *vars) { ENTER(convertVarListToList); if (vars == NULL) { LEAVE(convertVarListToList); @@ -90,7 +90,7 @@ static LamArgs *convertVarListToList(LamVarList *vars) { } LamArgs *next = convertVarListToList(vars->next); int save = PROTECT(next); - LamExp *exp = newLamExp_Var(I, vars->var); + LamExp *exp = newLamExp_Var(I, vars->symbol); PROTECT(exp); LamArgs *this = newLamArgs(I, exp, next); UNPROTECT(save); @@ -102,7 +102,7 @@ static LamExp *translateToApply(HashSymbol *name, TpmcState *dfa) { ENTER(translateToApply); LamExp *function = newLamExp_Var(I, name); int save = PROTECT(function); - LamVarList *cargs = makeCanonicalArgs(dfa->freeVariables); + SymbolList *cargs = makeCanonicalArgs(dfa->freeVariables); PROTECT(cargs); LamArgs *args = convertVarListToList(cargs); PROTECT(args); @@ -116,7 +116,7 @@ static LamExp *translateToLambda(TpmcState *dfa, LamExpTable *lambdaCache) { ENTER(translateToLambda); LamExp *exp = translateStateToInlineCode(dfa, lambdaCache); int save = PROTECT(exp); - LamVarList *args = makeCanonicalArgs(dfa->freeVariables); + SymbolList *args = makeCanonicalArgs(dfa->freeVariables); PROTECT(args); LamExp *res = makeLamExp_Lam(I, args, exp); UNPROTECT(save); @@ -147,92 +147,78 @@ static LamExp *translateComparisonArcToTest(TpmcArc *arc) { ENTER(translateComparisonArcToTest); #ifdef SAFETY_CHECKS if (arc->test->pattern->type != TPMCPATTERNVALUE_TYPE_COMPARISON) { - cant_happen - ("translateComparisonArcToTest encountered non-comparison type %d", - arc->test->pattern->type); + cant_happen( + "translateComparisonArcToTest encountered non-comparison type %d", + arc->test->pattern->type); } #endif - TpmcComparisonPattern *pattern = getTpmcPatternValue_Comparison(arc->test->pattern); - LamExp *a = - newLamExp_Var(I, pattern->previous->path); + TpmcComparisonPattern *pattern = + getTpmcPatternValue_Comparison(arc->test->pattern); + LamExp *a = newLamExp_Var(I, pattern->previous->path); int save = PROTECT(a); - LamExp *b = - newLamExp_Var(I, pattern->current->path); + LamExp *b = newLamExp_Var(I, pattern->current->path); PROTECT(b); - LamPrimApp *eq = newLamPrimApp(I, LAMPRIMOP_TYPE_EQ, a, b); - PROTECT(eq); - LamExp *res = newLamExp_Prim(I, eq); + LamExp *res = makeLamExp_Prim(I, LAMPRIMOP_TYPE_EQ, a, b); UNPROTECT(save); LEAVE(translateComparisonArcToTest); return res; } -static LamExp *prependLetBindings(TpmcPattern *test, - TpmcVariableTable *freeVariables, +static LamExp *prependLetBindings(TpmcPattern *test, SymbolSet *freeVariables, LamExp *body) { ENTER(prependLetBindings); int save = PROTECT(body); switch (test->pattern->type) { - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { - TpmcConstructorPattern *constructor = getTpmcPatternValue_Constructor(test->pattern); - TpmcPatternArray *components = constructor->components; - HashSymbol *name = constructor->info->type->name; - DEBUG("constructor %s has size %d", name->name, components->size); - IFDEBUG(ppTpmcConstructorPattern(constructor)); - for (Index i = 0; i < components->size; i++) { - HashSymbol *path = components->entries[i]->path; - DEBUG("considering variable %s", path->name); - if (getTpmcVariableTable(freeVariables, path)) { - DEBUG("%s is free", path->name); - LamExp *base = - newLamExp_Var(I, test->path); - int save2 = PROTECT(base); - LamDeconstruct *deconstruct = - newLamDeconstruct(I, name, constructor->info->nsId, i + 1, base); - PROTECT(deconstruct); - LamExp *deconstructExp = newLamExp_Deconstruct(I, deconstruct); - PROTECT(deconstructExp); - LamBindings *bindings = newLamBindings(I, path, deconstructExp, NULL); - PROTECT(bindings); - LamLet *let = newLamLet(I, bindings, body); - PROTECT(let); - body = newLamExp_Let(I, let); - REPLACE_PROTECT(save, body); - UNPROTECT(save2); - } else { - DEBUG("%s is not free", path->name); - } + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + TpmcConstructorPattern *constructor = + getTpmcPatternValue_Constructor(test->pattern); + TpmcPatternArray *components = constructor->components; + HashSymbol *name = constructor->info->type->name; + DEBUG("constructor %s has size %d", name->name, components->size); + IFDEBUG(ppTpmcConstructorPattern(constructor)); + for (Index i = 0; i < components->size; i++) { + HashSymbol *path = components->entries[i]->path; + DEBUG("considering variable %s", path->name); + if (getSymbolSet(freeVariables, path)) { + DEBUG("%s is free", path->name); + LamExp *base = newLamExp_Var(I, test->path); + int save2 = PROTECT(base); + LamExp *deconstructExp = makeLamExp_Deconstruct( + I, name, constructor->info->nsId, i + 1, base); + PROTECT(deconstructExp); + LamBindings *bindings = + newLamBindings(I, path, deconstructExp, NULL); + PROTECT(bindings); + body = makeLamExp_Let(I, bindings, body); + REPLACE_PROTECT(save, body); + UNPROTECT(save2); + } else { + DEBUG("%s is not free", path->name); } } - break; - case TPMCPATTERNVALUE_TYPE_TUPLE: { - TpmcPatternArray *components = getTpmcPatternValue_Tuple(test->pattern); - int size = components->size; - for (int i = 0; i < size; i++) { - HashSymbol *path = components->entries[i]->path; - if (getTpmcVariableTable(freeVariables, path)) { - LamExp *base = - newLamExp_Var(I, test->path); - int save2 = PROTECT(base); - LamTupleIndex *index = newLamTupleIndex(I, i, size, base); - PROTECT(index); - LamExp *tupleIndex = newLamExp_TupleIndex(I, index); - PROTECT(tupleIndex); - LamBindings *bindings = - newLamBindings(I, path, tupleIndex, NULL); - PROTECT(bindings); - LamLet *let = newLamLet(I, bindings, body); - PROTECT(let); - body = newLamExp_Let(I, let); - REPLACE_PROTECT(save, body); - UNPROTECT(save2); - } + } break; + case TPMCPATTERNVALUE_TYPE_TUPLE: { + TpmcPatternArray *components = getTpmcPatternValue_Tuple(test->pattern); + int size = components->size; + for (int i = 0; i < size; i++) { + HashSymbol *path = components->entries[i]->path; + if (getSymbolSet(freeVariables, path)) { + LamExp *base = newLamExp_Var(I, test->path); + int save2 = PROTECT(base); + LamExp *tupleIndex = makeLamExp_TupleIndex(I, i, size, base); + PROTECT(tupleIndex); + LamBindings *bindings = + newLamBindings(I, path, tupleIndex, NULL); + PROTECT(bindings); + body = makeLamExp_Let(I, bindings, body); + REPLACE_PROTECT(save, body); + UNPROTECT(save2); } } - break; - default: - cant_happen("prependLetBindings passed non-constructor %s", - tpmcPatternValueTypeName(test->pattern->type)); + } break; + default: + cant_happen("prependLetBindings passed non-constructor %s", + tpmcPatternValueTypeName(test->pattern->type)); } LEAVE(prependLetBindings); UNPROTECT(save); @@ -243,23 +229,22 @@ static LamExp *translateArcToCode(TpmcArc *arc, LamExpTable *lambdaCache) { ENTER(translateArcToCode); LamExp *res = translateState(arc->state, lambdaCache); switch (arc->test->pattern->type) { - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: - case TPMCPATTERNVALUE_TYPE_TUPLE: { - int save = PROTECT(res); - res = prependLetBindings(arc->test, arc->state->freeVariables, res); - UNPROTECT(save); - } + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: + case TPMCPATTERNVALUE_TYPE_TUPLE: { + int save = PROTECT(res); + res = prependLetBindings(arc->test, arc->state->freeVariables, res); + UNPROTECT(save); + } break; + default: break; - default: - break; } LEAVE(translateArcToCode); return res; } -static LamExp *translateComparisonArcAndAlternativeToIf(TpmcArc *arc, LamExpTable - *lambdaCache, - LamExp *alternative) { +static LamExp * +translateComparisonArcAndAlternativeToIf(TpmcArc *arc, LamExpTable *lambdaCache, + LamExp *alternative) { ENTER(translateComparisonArcAndAlternativeToIf); // (if (eq p$0 p$1) ... ...) ; both variables LamExp *test = translateComparisonArcToTest(arc); @@ -290,20 +275,22 @@ static TpmcArcList *arcArrayToList(TpmcArcArray *arcArray) { // may need a context i.e. the type of test this is contained in for index > 0 // -// The state consists of a variable to be tested, and an ordered list of arcs to other states. -// Each arc has a pattern to match and a result state. -// The pattern can be a comparison, a constant, a constructor or a wildCard. -// Any one state cannot have arcs with both constructor and constant patterns. -// Only the last arc may have a wildCard pattern. +// The state consists of a variable to be tested, and an ordered list of arcs to +// other states. Each arc has a pattern to match and a result state. The pattern +// can be a comparison, a constant, a constructor or a wildCard. Any one state +// cannot have arcs with both constructor and constant patterns. Only the last +// arc may have a wildCard pattern. // // So in the absence of comparisons, everything would be simple. -// either a list of constants followed by a wildCard, or a list of constructors, optionally -// followed by a wildCard if the list of constructors is not exhaustive. -// we would either construct a (cond ... (default ...)) test for constants, or a -// (match ... ((n m) ...)) test for constructors, wher (n m) is the unexhausted constructor indices. +// either a list of constants followed by a wildCard, or a list of constructors, +// optionally followed by a wildCard if the list of constructors is not +// exhaustive. we would either construct a (cond ... (default ...)) test for +// constants, or a (match ... ((n m) ...)) test for constructors, wher (n m) is +// the unexhausted constructor indices. // -// The presence of a comparison test forces us to interject a premature default clause for the -// constants or constructors so far encountered, followed by a new cond or match clause for the remainder. +// The presence of a comparison test forces us to interject a premature default +// clause for the constants or constructors so far encountered, followed by a +// new cond or match clause for the remainder. // // example: // fn awkward { @@ -321,7 +308,7 @@ static TpmcArcList *arcArrayToList(TpmcArcArray *arcArray) { // '!' // (cond p$1 ('c' 'C') // (default 'D'))))) -// +// static LamExp *translateArcList(TpmcArcList *arcList, LamExp *testVar, LamExpTable *lambdaCache); static LamIntCondCases *translateConstantIntArcList(TpmcArcList *arcList, @@ -329,11 +316,10 @@ static LamIntCondCases *translateConstantIntArcList(TpmcArcList *arcList, LamExpTable *lambdaCache); static LamCharCondCases *translateConstantCharArcList(TpmcArcList *arcList, LamExp *testVar, - LamExpTable - *lambdaCache); + LamExpTable *lambdaCache); static LamMatchList *translateConstructorArcList(TpmcArcList *arcList, - LamExp *testVar, LamIntList - *unexhaustedIndices, + LamExp *testVar, + LamIntList *unexhaustedIndices, LamExpTable *lambdaCache); static LamExp *translateTestState(TpmcTestState *testState, @@ -341,8 +327,7 @@ static LamExp *translateTestState(TpmcTestState *testState, ENTER(translateTestState); TpmcArcList *arcList = arcArrayToList(testState->arcs); int save = PROTECT(arcList); - LamExp *testVar = - newLamExp_Var(I, testState->path); + LamExp *testVar = newLamExp_Var(I, testState->path); PROTECT(testVar); LamExp *res = translateArcList(arcList, testVar, lambdaCache); UNPROTECT(save); @@ -384,9 +369,8 @@ static LamExp *translateComparisonArcListToIf(TpmcArcList *arcList, LamExpTable *lambdaCache) { LamExp *rest = translateArcList(arcList->next, testVar, lambdaCache); int save = PROTECT(rest); - LamExp *res = - translateComparisonArcAndAlternativeToIf(arcList->arc, lambdaCache, - rest); + LamExp *res = translateComparisonArcAndAlternativeToIf(arcList->arc, + lambdaCache, rest); UNPROTECT(save); return res; } @@ -401,69 +385,63 @@ static LamExp *translateArcList(TpmcArcList *arcList, LamExp *testVar, #endif LamExp *res = NULL; switch (arcList->arc->test->pattern->type) { - case TPMCPATTERNVALUE_TYPE_COMPARISON:{ - res = - translateComparisonArcListToIf(arcList, testVar, - lambdaCache); - break; - } - case TPMCPATTERNVALUE_TYPE_CHARACTER:{ - LamCharCondCases *charCases = - translateConstantCharArcList(arcList, testVar, - lambdaCache); - int save = PROTECT(charCases); - LamCondCases *cases = newLamCondCases_Characters(I, charCases); - PROTECT(cases); - res = makeLamExp_Cond(I, testVar, cases); - UNPROTECT(save); - break; - } - case TPMCPATTERNVALUE_TYPE_BIGINTEGER:{ - LamIntCondCases *intCases = - translateConstantIntArcList(arcList, testVar, - lambdaCache); - int save = PROTECT(intCases); - LamCondCases *cases = newLamCondCases_Integers(I, intCases); - PROTECT(cases); - res = makeLamExp_Cond(I, testVar, cases); - UNPROTECT(save); - break; - } - case TPMCPATTERNVALUE_TYPE_WILDCARD:{ - LamExp *res = - translateState(arcList->arc->state, lambdaCache); - return res; - } - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ - LamTypeConstructorInfo *info = - getTpmcPatternValue_Constructor(arcList->arc->test->pattern)->info; - LamIntList *unexhaustedIndices = makeUnexhaustedIndices(info); - int save = PROTECT(unexhaustedIndices); - LamMatchList *matches = - translateConstructorArcList(arcList, testVar, - unexhaustedIndices, - lambdaCache); - PROTECT(matches); - LamExp *testExp = NULL; - if (info->needsVec) { - testExp = - newLamExp_Tag(I, testVar); - PROTECT(testExp); - } else { - testExp = testVar; - } - LamMatch *match = newLamMatch(I, testExp, matches); - PROTECT(match); - res = newLamExp_Match(I, match); - UNPROTECT(save); - break; - } - case TPMCPATTERNVALUE_TYPE_TUPLE:{ - res = translateArcToCode(arcList->arc, lambdaCache); - break; + case TPMCPATTERNVALUE_TYPE_COMPARISON: { + res = translateComparisonArcListToIf(arcList, testVar, lambdaCache); + break; + } + case TPMCPATTERNVALUE_TYPE_CHARACTER: { + LamCharCondCases *charCases = + translateConstantCharArcList(arcList, testVar, lambdaCache); + int save = PROTECT(charCases); + LamCondCases *cases = newLamCondCases_Characters(I, charCases); + PROTECT(cases); + res = makeLamExp_Cond(I, testVar, cases); + UNPROTECT(save); + break; + } + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: { + LamIntCondCases *intCases = + translateConstantIntArcList(arcList, testVar, lambdaCache); + int save = PROTECT(intCases); + LamCondCases *cases = newLamCondCases_Integers(I, intCases); + PROTECT(cases); + res = makeLamExp_Cond(I, testVar, cases); + UNPROTECT(save); + break; + } + case TPMCPATTERNVALUE_TYPE_WILDCARD: { + LamExp *res = translateState(arcList->arc->state, lambdaCache); + return res; + } + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + LamTypeConstructorInfo *info = + getTpmcPatternValue_Constructor(arcList->arc->test->pattern)->info; + LamIntList *unexhaustedIndices = makeUnexhaustedIndices(info); + int save = PROTECT(unexhaustedIndices); + LamMatchList *matches = translateConstructorArcList( + arcList, testVar, unexhaustedIndices, lambdaCache); + PROTECT(matches); + LamExp *testExp = NULL; + if (info->needsVec) { + testExp = newLamExp_Tag(I, testVar); + PROTECT(testExp); + } else { + testExp = testVar; } - default: - cant_happen("unrecognised type %s", tpmcPatternValueTypeName(arcList->arc->test->pattern->type)); + LamMatch *match = newLamMatch(I, testExp, matches); + PROTECT(match); + res = newLamExp_Match(I, match); + UNPROTECT(save); + break; + } + case TPMCPATTERNVALUE_TYPE_TUPLE: { + res = translateArcToCode(arcList->arc, lambdaCache); + break; + } + default: + cant_happen( + "unrecognised type %s", + tpmcPatternValueTypeName(arcList->arc->test->pattern->type)); } LEAVE(translateArcList); return res; @@ -509,8 +487,7 @@ static LamCharCondCases *makeCharCondDefault(LamExp *action) { static LamIntCondCases *translateConstantIntArcList(TpmcArcList *arcList, LamExp *testVar, - LamExpTable *lambdaCache) -{ + LamExpTable *lambdaCache) { #ifdef SAFETY_CHECKS if (arcList == NULL) { cant_happen("ran out of arcs in translateConstantIntArcList"); @@ -519,47 +496,43 @@ static LamIntCondCases *translateConstantIntArcList(TpmcArcList *arcList, ENTER(translateConstantIntArcList); LamIntCondCases *res = NULL; switch (arcList->arc->test->pattern->type) { - case TPMCPATTERNVALUE_TYPE_COMPARISON:{ - // (default ... - LamExp *iff = translateComparisonArcListToIf(arcList, testVar, - lambdaCache); - int save = PROTECT(iff); - res = makeIntCondDefault(iff); - UNPROTECT(save); - break; - } - case TPMCPATTERNVALUE_TYPE_CHARACTER:{ - cant_happen - ("encountered character case when cinstructing an integer cond"); - } - case TPMCPATTERNVALUE_TYPE_BIGINTEGER:{ - MaybeBigInt *integer = getTpmcPatternValue_BigInteger(arcList->arc->test->pattern); - res = - makeConstantIntCondCase(arcList, integer, testVar, - lambdaCache); - break; - } - case TPMCPATTERNVALUE_TYPE_WILDCARD:{ - LamExp *body = - translateState(arcList->arc->state, lambdaCache); - int save = PROTECT(body); - res = makeIntCondDefault(body); - UNPROTECT(save); - break; - } - default: - cant_happen - ("unrecognized pattern type %d in translateConstantArcList", - arcList->arc->test->pattern->type); + case TPMCPATTERNVALUE_TYPE_COMPARISON: { + // (default ... + LamExp *iff = + translateComparisonArcListToIf(arcList, testVar, lambdaCache); + int save = PROTECT(iff); + res = makeIntCondDefault(iff); + UNPROTECT(save); + break; + } + case TPMCPATTERNVALUE_TYPE_CHARACTER: { + cant_happen( + "encountered character case when cinstructing an integer cond"); + } + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: { + MaybeBigInt *integer = + getTpmcPatternValue_BigInteger(arcList->arc->test->pattern); + res = makeConstantIntCondCase(arcList, integer, testVar, lambdaCache); + break; + } + case TPMCPATTERNVALUE_TYPE_WILDCARD: { + LamExp *body = translateState(arcList->arc->state, lambdaCache); + int save = PROTECT(body); + res = makeIntCondDefault(body); + UNPROTECT(save); + break; + } + default: + cant_happen("unrecognized pattern type %d in translateConstantArcList", + arcList->arc->test->pattern->type); } LEAVE(translateConstantArcList); return res; } -static LamCharCondCases *translateConstantCharArcList(TpmcArcList *arcList, - LamExp *testVar, - LamExpTable - *lambdaCache) { +static LamCharCondCases * +translateConstantCharArcList(TpmcArcList *arcList, LamExp *testVar, + LamExpTable *lambdaCache) { #ifdef SAFETY_CHECKS if (arcList == NULL) { cant_happen("ran out of arcs in translateConstantCharArcList"); @@ -568,46 +541,44 @@ static LamCharCondCases *translateConstantCharArcList(TpmcArcList *arcList, ENTER(translateConstantCharArcList); LamCharCondCases *res = NULL; switch (arcList->arc->test->pattern->type) { - case TPMCPATTERNVALUE_TYPE_COMPARISON:{ - // (default ... - LamExp *iff = translateComparisonArcListToIf(arcList, testVar, - lambdaCache); - int save = PROTECT(iff); - res = makeCharCondDefault(iff); - UNPROTECT(save); - break; - } - case TPMCPATTERNVALUE_TYPE_CHARACTER:{ - Character character = getTpmcPatternValue_Character(arcList->arc->test->pattern); - res = - makeConstantCharCondCase(arcList, character, testVar, - lambdaCache); - break; - } - case TPMCPATTERNVALUE_TYPE_BIGINTEGER:{ - cant_happen - ("encountered integer case when constructing a character cond"); - } - case TPMCPATTERNVALUE_TYPE_WILDCARD:{ - LamExp *body = - translateState(arcList->arc->state, lambdaCache); - int save = PROTECT(body); - res = makeCharCondDefault(body); - UNPROTECT(save); - break; - } - default: - cant_happen - ("unrecognized pattern type %d in translateConstantArcList", - arcList->arc->test->pattern->type); + case TPMCPATTERNVALUE_TYPE_COMPARISON: { + // (default ... + LamExp *iff = + translateComparisonArcListToIf(arcList, testVar, lambdaCache); + int save = PROTECT(iff); + res = makeCharCondDefault(iff); + UNPROTECT(save); + break; + } + case TPMCPATTERNVALUE_TYPE_CHARACTER: { + Character character = + getTpmcPatternValue_Character(arcList->arc->test->pattern); + res = + makeConstantCharCondCase(arcList, character, testVar, lambdaCache); + break; + } + case TPMCPATTERNVALUE_TYPE_BIGINTEGER: { + cant_happen( + "encountered integer case when constructing a character cond"); + } + case TPMCPATTERNVALUE_TYPE_WILDCARD: { + LamExp *body = translateState(arcList->arc->state, lambdaCache); + int save = PROTECT(body); + res = makeCharCondDefault(body); + UNPROTECT(save); + break; + } + default: + cant_happen("unrecognized pattern type %d in translateConstantArcList", + arcList->arc->test->pattern->type); } LEAVE(translateConstantArcList); return res; } static LamMatchList *translateConstructorArcList(TpmcArcList *arcList, - LamExp *testVar, LamIntList - *unexhaustedIndices, + LamExp *testVar, + LamIntList *unexhaustedIndices, LamExpTable *lambdaCache) { ENTER(translateConstructorArcList); if (arcList == NULL) { @@ -615,8 +586,8 @@ static LamMatchList *translateConstructorArcList(TpmcArcList *arcList, LEAVE(translateConstructorArcList); return NULL; } else { - cant_happen - ("ran out of arcs with unexhausted indices in translateConstructorArcList"); + cant_happen("ran out of arcs with unexhausted indices in " + "translateConstructorArcList"); } } #ifdef SAFETY_CHECKS @@ -626,47 +597,43 @@ static LamMatchList *translateConstructorArcList(TpmcArcList *arcList, #endif LamMatchList *res = NULL; switch (arcList->arc->test->pattern->type) { - case TPMCPATTERNVALUE_TYPE_COMPARISON:{ - LamExp *iff = translateComparisonArcListToIf(arcList, testVar, - lambdaCache); - int save = PROTECT(iff); - res = newLamMatchList(I, unexhaustedIndices, iff, NULL); - UNPROTECT(save); - break; - } - case TPMCPATTERNVALUE_TYPE_WILDCARD:{ - LamExp *body = - translateState(arcList->arc->state, lambdaCache); - int save = PROTECT(body); - res = newLamMatchList(I, unexhaustedIndices, body, NULL); - UNPROTECT(save); - break; - } - case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR:{ - // remove this constructor's index from the list we pass downstream - LamTypeConstructorInfo *info = - getTpmcPatternValue_Constructor(arcList->arc->test->pattern)->info; - unexhaustedIndices = - removeIndex(info->index, unexhaustedIndices); - LamMatchList *next = - translateConstructorArcList(arcList->next, testVar, - unexhaustedIndices, - lambdaCache); - int save = PROTECT(next); - LamExp *body = translateArcToCode(arcList->arc, lambdaCache); - DEBUG("translateArcToCode returned %p", body); - PROTECT(body); - LamIntList *index = - newLamIntList(I, info->index, info->type->name, info->nsId, NULL); - PROTECT(index); - res = newLamMatchList(I, index, body, next); - UNPROTECT(save); - break; - } - default: - cant_happen - ("unrecognized pattern type %d in translateConstructorArcList", - arcList->arc->test->pattern->type); + case TPMCPATTERNVALUE_TYPE_COMPARISON: { + LamExp *iff = + translateComparisonArcListToIf(arcList, testVar, lambdaCache); + int save = PROTECT(iff); + res = newLamMatchList(I, unexhaustedIndices, iff, NULL); + UNPROTECT(save); + break; + } + case TPMCPATTERNVALUE_TYPE_WILDCARD: { + LamExp *body = translateState(arcList->arc->state, lambdaCache); + int save = PROTECT(body); + res = newLamMatchList(I, unexhaustedIndices, body, NULL); + UNPROTECT(save); + break; + } + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + // remove this constructor's index from the list we pass downstream + LamTypeConstructorInfo *info = + getTpmcPatternValue_Constructor(arcList->arc->test->pattern)->info; + unexhaustedIndices = removeIndex(info->index, unexhaustedIndices); + LamMatchList *next = translateConstructorArcList( + arcList->next, testVar, unexhaustedIndices, lambdaCache); + int save = PROTECT(next); + LamExp *body = translateArcToCode(arcList->arc, lambdaCache); + DEBUG("translateArcToCode returned %p", body); + PROTECT(body); + LamIntList *index = + newLamIntList(I, info->index, info->type->name, info->nsId, NULL); + PROTECT(index); + res = newLamMatchList(I, index, body, next); + UNPROTECT(save); + break; + } + default: + cant_happen( + "unrecognized pattern type %d in translateConstructorArcList", + arcList->arc->test->pattern->type); } LEAVE(translateConstructorArcList); return res; @@ -677,18 +644,19 @@ static LamExp *translateStateToInlineCode(TpmcState *dfa, ENTER(translateStateToInlineCode); LamExp *res = NULL; switch (dfa->state->type) { - case TPMCSTATEVALUE_TYPE_TEST: - res = translateTestState(getTpmcStateValue_Test(dfa->state), lambdaCache); - break; - case TPMCSTATEVALUE_TYPE_FINAL: - res = getTpmcStateValue_Final(dfa->state)->action; - break; - case TPMCSTATEVALUE_TYPE_ERROR: - res = newLamExp_Error(I); - break; - default: - cant_happen("unrecognised state type %d in tpmcTranslate", - dfa->state->type); + case TPMCSTATEVALUE_TYPE_TEST: + res = + translateTestState(getTpmcStateValue_Test(dfa->state), lambdaCache); + break; + case TPMCSTATEVALUE_TYPE_FINAL: + res = getTpmcStateValue_Final(dfa->state)->action; + break; + case TPMCSTATEVALUE_TYPE_ERROR: + res = newLamExp_Error(I); + break; + default: + cant_happen("unrecognised state type %d in tpmcTranslate", + dfa->state->type); } LEAVE(translateStateToInlineCode); return res; @@ -709,19 +677,18 @@ static LamExp *translateState(TpmcState *dfa, LamExpTable *lambdaCache) { static void resetStateRefCountsToZero(TpmcState *dfa) { dfa->refCount = 0; switch (dfa->state->type) { - case TPMCSTATEVALUE_TYPE_TEST:{ - TpmcArcArray *arcs = getTpmcStateValue_Test(dfa->state)->arcs; - for (Index i = 0; i < arcs->size; ++i) { - resetStateRefCountsToZero(arcs->entries[i]->state); - } + case TPMCSTATEVALUE_TYPE_TEST: { + TpmcArcArray *arcs = getTpmcStateValue_Test(dfa->state)->arcs; + for (Index i = 0; i < arcs->size; ++i) { + resetStateRefCountsToZero(arcs->entries[i]->state); } + } break; + case TPMCSTATEVALUE_TYPE_FINAL: + case TPMCSTATEVALUE_TYPE_ERROR: break; - case TPMCSTATEVALUE_TYPE_FINAL: - case TPMCSTATEVALUE_TYPE_ERROR: - break; - default: - cant_happen("unrecognised type %d in resetStateRefCountToZero", - dfa->state->type); + default: + cant_happen("unrecognised type %d in resetStateRefCountToZero", + dfa->state->type); } } @@ -729,20 +696,18 @@ static void incrementStateRefCounts(TpmcState *dfa) { dfa->refCount++; if (dfa->refCount == 1) { switch (dfa->state->type) { - case TPMCSTATEVALUE_TYPE_TEST:{ - TpmcArcArray *arcs = getTpmcStateValue_Test(dfa->state)->arcs; - for (Index i = 0; i < arcs->size; ++i) { - incrementStateRefCounts(arcs->entries[i]->state); - } + case TPMCSTATEVALUE_TYPE_TEST: { + TpmcArcArray *arcs = getTpmcStateValue_Test(dfa->state)->arcs; + for (Index i = 0; i < arcs->size; ++i) { + incrementStateRefCounts(arcs->entries[i]->state); } + } break; + case TPMCSTATEVALUE_TYPE_FINAL: + case TPMCSTATEVALUE_TYPE_ERROR: break; - case TPMCSTATEVALUE_TYPE_FINAL: - case TPMCSTATEVALUE_TYPE_ERROR: - break; - default: - cant_happen - ("unrecognised type %d in resetStateRefCountToZero", - dfa->state->type); + default: + cant_happen("unrecognised type %d in resetStateRefCountToZero", + dfa->state->type); } } } diff --git a/src/types.h b/src/types.h index 58526457..1ca8fc48 100644 --- a/src/types.h +++ b/src/types.h @@ -1,5 +1,5 @@ #ifndef cekf_types_h -# define cekf_types_h +#define cekf_types_h /* * CEKF - VM supporting amb * Copyright (C) 2022-2023 Bill Hails @@ -17,13 +17,13 @@ * You should have received a copy of the GNU General Public License * along with this program. If not, see . * - * typedefs to allow different sizes of data and to avoid using primitive types directly. - * for example we may want characters to be wchar_t at some point. + * typedefs to allow different sizes of data and to avoid using primitive types + * directly. for example we may want characters to be wchar_t at some point. */ -# include -# include -# include +#include +#include +#include /* * on my machine: @@ -43,7 +43,7 @@ typedef uint8_t Byte; typedef wchar_t Character; -typedef unsigned short int Word; +typedef unsigned int Word; typedef int Integer; typedef unsigned int Index; typedef double Double; @@ -56,4 +56,4 @@ typedef struct StackFrame { #define END_CONTROL UINT64_MAX - #endif +#endif diff --git a/src/utils.yaml b/src/utils.yaml new file mode 100644 index 00000000..c5ca3c4c --- /dev/null +++ b/src/utils.yaml @@ -0,0 +1,116 @@ +# +# CEKF - VM supporting amb +# Copyright (C) 2022-2025 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: utils + description: Common utility structures + parserInfo: false + limited_includes: + - ast_helper.h + - sys/stat.h + +structs: + FileId: + meta: + brief: Unambiguous File Identifier + eqIgnore: + - fileName + data: + stDev: device + stIno: inode + fileName: SCharVec + + SymbolList: + meta: + brief: A list of Symbols + parserInfo: true + data: + symbol: HashSymbol + next: SymbolList + +hashes: + SymbolSet: + meta: + brief: A set of Symbols + data: {} + + IntMap: + meta: + brief: Map from Symbol to Integer + data: + entries: int + + SymbolMap: + meta: + brief: Map from Symbol to Symbol + data: + entries: HashSymbol + +arrays: + StringArray: + meta: + brief: AST String Array + description: >- + A simple array of strings. + data: + entries: string + + WCharArray: + meta: + brief: A UTF-8 encoded string. + data: + entries: character + + UCharArray: + meta: + brief: An array of bytes + data: + entries: byte + + SCharArray: + meta: + brief: An array of schar + data: + entries: schar + + SymbolArray: + meta: + brief: Array of Symbols + data: + entries: HashSymbol + + IntArray: + meta: + brief: integer array + data: + entries: int + +vectors: + SCharVec: + meta: + brief: A vector of signed chars + data: + entries: schar + + WCharVec: + meta: + brief: A vector of wide chars + data: + entries: character + +primitives: !include primitives.yaml diff --git a/src/utils_helper.c b/src/utils_helper.c new file mode 100644 index 00000000..b53500d6 --- /dev/null +++ b/src/utils_helper.c @@ -0,0 +1,338 @@ +/* + * 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 "utils_helper.h" + +// These little helpers are a bit too specific to be generated. + +/** + * @brief Creates a new SCharVec from a C string, including the null terminator. + * @param str The C string to convert. + * @return A new SCharVec containing the characters of the string. + */ +SCharVec *stringToSCharVec(char *str) { + size_t len = strlen(str); + SCharVec *vec = newSCharVec(len + 1); + strcpy(vec->entries, str); + return vec; +} + +/** + * @brief Creates a new SCharArray from a C string, excluding the null + * terminator. + * @param str The C string to convert. + * @return A new SCharArray containing the characters of the string. + */ +SCharArray *stringToSCharArray(char *str) { + SCharArray *array = newSCharArray(); + int save = PROTECT(array); + size_t len = strlen(str); + extendSCharArray(array, len); + memcpy(array->entries, str, len); + UNPROTECT(save); + return array; +} + +/** + * @brief Appends a C string to an SCharArray, excluding the null terminator. + * @param array The SCharArray to append to. + * @param str The C string to append. + */ +void appendStringToSCharArray(SCharArray *array, char *str) { + addSCharArray(array, strlen(str)); + while (*str) { + pushSCharArray(array, *str); + str++; + } +} + +/** + * @brief Converts an SCharArray to an SCharVec, adding a null terminator. + * @param array The SCharArray to convert. + * @return A new SCharVec containing the characters of the array. + */ +SCharVec *sCharArrayToVec(SCharArray *array) { + SCharVec *vec = newSCharVec(array->size + 1); + memcpy(vec->entries, array->entries, array->size * sizeof(char)); + vec->entries[array->size] = '\0'; + return vec; +} + +/** + * @brief Converts an SCharVec to an SCharArray, dropping the null terminator. + * @param vec The SCharVec to convert. + * @return A new SCharArray containing the characters of the vector. + */ +SCharArray *sCharVecToArray(SCharVec *vec) { + SCharArray *array = newSCharArray(); + int save = PROTECT(array); + extendSCharArray(array, vec->size - 1); + memcpy(array->entries, vec->entries, (vec->size - 1) * sizeof(char)); + UNPROTECT(save); + return array; +} + +/** + * @brief Converts a WCharArray to a WCharVec, adding a null terminator. + * @param array The WCharArray to convert. + * @return A new WCharVec containing the characters of the array. + */ +WCharVec *wCharArrayToVec(WCharArray *array) { + WCharVec *vec = newWCharVec(array->size + 1); + memcpy(vec->entries, array->entries, array->size * sizeof(Character)); + vec->entries[array->size] = L'\0'; + return vec; +} + +/** + * @brief Converts a WCharVec to a WCharArray, dropping the null terminator. + * @param vec The WCharVec to convert. + * @return A new WCharArray containing the characters of the vector. + */ +WCharArray *wCharVecToArray(WCharVec *vec) { + WCharArray *array = newWCharArray(); + int save = PROTECT(array); + extendWCharArray(array, vec->size - 1); + memcpy(array->entries, vec->entries, (vec->size - 1) * sizeof(Character)); + UNPROTECT(save); + return array; +} + +/** + * @brief Converts a list of symbols to a set of symbols. + * @param list The list of symbols to convert. + * @return A new set of symbols containing the symbols from the list. + */ +SymbolSet *symbolListToSet(SymbolList *list) { + SymbolSet *set = newSymbolSet(); + int save = PROTECT(set); + while (list != NULL) { + setSymbolSet(set, list->symbol); + list = list->next; + } + UNPROTECT(save); + return set; +} + +/** + * @brief Converts a set of symbols to a list of symbols. + * @param PI The parser info for each element of the new list. + * @param set The set of symbols. + * @return The list of symbols. + */ +SymbolList *symbolSetToList(ParserInfo PI, SymbolSet *set) { + SymbolList *list = NULL; + int save = PROTECT(list); + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(set, &i)) != NULL) { + list = newSymbolList(PI, current, list); + } + UNPROTECT(save); + return list; +} + +/** + * @brief Exclude a symbol from a set of symbols. + * + * @param var The symbol to exclude. + * @param symbols The current set of symbols. + * @return A new set of symbols without the excluded symbol. + */ +SymbolSet *excludeSymbol(HashSymbol *var, SymbolSet *symbols) { + SymbolSet *new = newSymbolSet(); + int save = PROTECT(new); + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(symbols, &i)) != NULL) { + if (current != var) { + setSymbolSet(new, current); + } + } + UNPROTECT(save); + return new; +} + +/** + * @brief Copy a set of symbols. + * + * @param symbols The current set of symbols. + * @return A new set of symbols. + */ +SymbolSet *copySymbolSet(SymbolSet *symbols) { + SymbolSet *new = newSymbolSet(); + int save = PROTECT(new); + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(symbols, &i)) != NULL) { + setSymbolSet(new, current); + } + UNPROTECT(save); + return new; +} + +/** + * @brief Check if a symbol is in a list of symbols. + * + * @param var The symbol to check. + * @param vars The list of symbols to search in. + * @return True if the symbol is found, false otherwise. + */ +bool symbolInList(HashSymbol *var, SymbolList *vars) { + while (vars != NULL) { + if (var == vars->symbol) { + return true; + } + vars = vars->next; + } + return false; +} + +/** + * @brief Exclude a list of symbols from a set of symbols. + * + * @param vars The list of symbols to exclude. + * @param symbols The current set of symbols. + * @return A new set of symbols without the excluded symbols. + */ +SymbolSet *excludeSymbols(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 Check if any symbols in the list are in the set. + * + * @param vars The list of symbols to check. + * @param symbols The set of symbols. + * @return True if any symbol is in the set, false otherwise. + */ +bool anySymbolInSet(SymbolList *vars, SymbolSet *symbols) { + while (vars != NULL) { + if (getSymbolSet(symbols, vars->symbol)) { + return true; + } + vars = vars->next; + } + return false; +} + +/** + * @brief Check if all symbols in the list are in the set. + * + * @param vars The list of symbols to check. + * @param symbols The set of symbols. + * @return True if all symbols are in the set, false otherwise. + */ +bool allSymbolsInSet(SymbolList *vars, SymbolSet *symbols) { + while (vars != NULL) { + if (!getSymbolSet(symbols, vars->symbol)) { + return false; + } + vars = vars->next; + } + return true; +} + +/** + * @brief The union of two sets of symbols. + * @param a The first set of symbols. + * @param b The second set of symbols. + * @return a ∪ b. + */ +SymbolSet *unionSymbolSet(SymbolSet *a, SymbolSet *b) { + SymbolSet *new = copySymbolSet(a); + int save = PROTECT(new); + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(b, &i)) != NULL) { + setSymbolSet(new, current); + } + UNPROTECT(save); + return new; +} + +/** + * @brief The intersection of two sets of symbols. + * @param a The first set of symbols. + * @param b The second set of symbols. + * @return a ∩ b. + */ +SymbolSet *intersectSymbolSet(SymbolSet *a, SymbolSet *b) { + SymbolSet *new = newSymbolSet(); + int save = PROTECT(new); + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(a, &i)) != NULL) { + if (getSymbolSet(b, current)) { + setSymbolSet(new, current); + } + } + UNPROTECT(save); + return new; +} + +/** + * @brief The difference of two sets of symbols. + * @param a The first set of symbols. + * @param b The second set of symbols. + * @return a - b. + */ +SymbolSet *differenceSymbolSet(SymbolSet *a, SymbolSet *b) { + SymbolSet *new = newSymbolSet(); + int save = PROTECT(new); + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(a, &i)) != NULL) { + if (!getSymbolSet(b, current)) { + setSymbolSet(new, current); + } + } + UNPROTECT(save); + return new; +} + +/** + * @brief Check if two sets of symbols are equal. + * + * @param a The first set of symbols. + * @param b The second set of symbols. + * @return True if the sets are equal, false otherwise. + */ +bool eqSymbolSet(SymbolSet *a, SymbolSet *b) { + if (countSymbolSet(a) != countSymbolSet(b)) { + return false; + } + Index i = 0; + HashSymbol *current; + while ((current = iterateSymbolSet(a, &i)) != NULL) { + if (!getSymbolSet(b, current)) { + return false; + } + } + return true; +} \ No newline at end of file diff --git a/src/utils_helper.h b/src/utils_helper.h new file mode 100644 index 00000000..1970ad83 --- /dev/null +++ b/src/utils_helper.h @@ -0,0 +1,46 @@ +#ifndef cekf_utils_helper_h +#define cekf_utils_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 "utils.h" + +SCharVec *stringToSCharVec(char *str); // keeps null terminator +SCharArray *stringToSCharArray(char *str); // drops null terminator +void appendStringToSCharArray(SCharArray *array, + char *str); // drops null terminator +SCharVec *sCharArrayToVec(SCharArray *array); // adds null terminator +SCharArray *sCharVecToArray(SCharVec *vec); // drops null terminator + +WCharVec *wCharArrayToVec(WCharArray *array); // adds null terminator +WCharArray *wCharVecToArray(WCharVec *vec); // drops null terminator + +SymbolSet *symbolListToSet(SymbolList *list); +SymbolList *symbolSetToList(ParserInfo PI, SymbolSet *set); +SymbolSet *excludeSymbol(HashSymbol *var, SymbolSet *symbols); +SymbolSet *copySymbolSet(SymbolSet *symbols); +bool symbolInList(HashSymbol *var, SymbolList *vars); +SymbolSet *excludeSymbols(SymbolList *vars, SymbolSet *symbols); +bool anySymbolInSet(SymbolList *vars, SymbolSet *symbols); +bool allSymbolsInSet(SymbolList *vars, SymbolSet *symbols); +SymbolSet *unionSymbolSet(SymbolSet *a, SymbolSet *b); +SymbolSet *intersectSymbolSet(SymbolSet *a, SymbolSet *b); +SymbolSet *differenceSymbolSet(SymbolSet *a, SymbolSet *b); +bool eqSymbolSet(SymbolSet *a, SymbolSet *b); + +#endif diff --git a/src/wrapper_synthesis.c b/src/wrapper_synthesis.c index 5d3178ed..d8c2039c 100644 --- a/src/wrapper_synthesis.c +++ b/src/wrapper_synthesis.c @@ -1,20 +1,19 @@ #include "wrapper_synthesis.h" -#include "memory.h" -#include "symbol.h" #include "ast.h" +#include "memory.h" #include "parser_info.h" +#include "symbol.h" #include AstDefinitions *generatedBuiltins = NULL; -void markGeneratedBuiltins(void) { - markAstDefinitions(generatedBuiltins); -} +void markGeneratedBuiltins(void) { markAstDefinitions(generatedBuiltins); } /* * Build a formal argument list (AstFargList) and parallel actual argument list * (AstExpressions) for n arguments named a$0 .. a$(n-1). */ -static void makeArgLists(ParserInfo PI, int n, AstFargList **formalOut, AstExpressions **actualOut) { +static void makeArgLists(ParserInfo PI, int n, AstFargList **formalOut, + AstExpressions **actualOut) { AstFargList *formals = NULL; AstExpressions *actuals = NULL; int saveFormals = PROTECT(NULL); @@ -42,18 +41,18 @@ static void makeArgLists(ParserInfo PI, int n, AstFargList **formalOut, AstExpre * Create wrapper definition AST for one builtin. */ static AstDefinition *makeWrapper(ParserInfo PI, BuiltIn *builtin) { - int arity = (int) builtin->args->size; + int arity = (int)builtin->args->size; AstFargList *formals = NULL; AstExpressions *actuals = NULL; makeArgLists(PI, arity, &formals, &actuals); // reference internal symbol int save = PROTECT(formals); PROTECT(actuals); - AstExpression *internalSym = newAstExpression_Symbol(PI, builtin->internalName); + AstExpression *internalSym = + newAstExpression_Symbol(PI, builtin->internalName); PROTECT(internalSym); - AstFunCall *call = newAstFunCall(PI, internalSym, actuals); - PROTECT(call); - AstExpression *bodyExpr = newAstExpression_FunCall(PI, call); + AstExpression *bodyExpr = + makeAstExpression_FunCall(PI, internalSym, actuals); PROTECT(bodyExpr); AstExpressions *bodyExprs = newAstExpressions(PI, bodyExpr, NULL); PROTECT(bodyExprs); @@ -61,19 +60,17 @@ static AstDefinition *makeWrapper(ParserInfo PI, BuiltIn *builtin) { PROTECT(nest); AstFunction *func = newAstFunction(PI, formals, nest); PROTECT(func); - AstCompositeFunction *comp = newAstCompositeFunction(PI, func, NULL); - PROTECT(comp); - AstExpression *funExpr = newAstExpression_Fun(PI, comp); + AstExpression *funExpr = makeAstExpression_Fun(PI, func, NULL); PROTECT(funExpr); - AstDefine *define = newAstDefine(PI, builtin->externalName, funExpr); - PROTECT(define); - AstDefinition *def = newAstDefinition_Define(PI, define); + AstDefinition *def = + makeAstDefinition_Define(PI, builtin->externalName, funExpr); UNPROTECT(save); return def; } void generateBuiltinWrappers(BuiltIns *builtIns) { - if (builtIns == NULL) return; + if (builtIns == NULL) + return; #ifdef SAFETY_CHECKS if (generatedBuiltins != NULL) cant_happen("generateBuiltinWrappers called twice"); @@ -84,12 +81,14 @@ void generateBuiltinWrappers(BuiltIns *builtIns) { PI.fileName = ""; PI.lineNo = 0; // Prepend wrappers so external names are resolved during type checking of - // preamble functions/macros that reference them (e.g. assertion, puts, etc.) + // preamble functions/macros that reference them (e.g. assertion, puts, + // etc.) for (Index i = 0; i < builtIns->size; i++) { BuiltIn *bi = builtIns->entries[i]; AstDefinition *wrapper = makeWrapper(PI, bi); int save = PROTECT(wrapper); - generatedBuiltins = newAstDefinitions(CPI(wrapper), wrapper, generatedBuiltins); + generatedBuiltins = + newAstDefinitions(CPI(wrapper), wrapper, generatedBuiltins); UNPROTECT(save); } } diff --git a/tests/fn/bug_fail_over_application.fn b/tests/fn/bug_fail_over_application.fn new file mode 100644 index 00000000..09325e05 --- /dev/null +++ b/tests/fn/bug_fail_over_application.fn @@ -0,0 +1,16 @@ +// Over-application exposes let/lambda desugaring bug +// Same root cause as namespace-let-bytecode bug: +// Let bindings desugar to lambda applications `((lambda (r1) body) value)`. +// When the value expression involves over-application, the VM exits +// prematurely when reaching the NULL continuation, before applying +// the lambda that represents the let body. +// The assertion never runs because the lambda `(lambda (r1) assert(false))` +// is never applied. + +let + fun1 = fn (x, y) { fn (z) { x + y + z } }; + r1 = fun1(1, 2, 3); // Over-application: after this completes with result 6, + // the lambda `(lambda (r1) assert(false))` should be + // applied, but the VM exits instead. +in + assert(false); // never gets here diff --git a/tests/fn/bug_slow_tpmc.fn b/tests/fn/bug_slow_tpmc.fn deleted file mode 100644 index b8f47f06..00000000 --- a/tests/fn/bug_slow_tpmc.fn +++ /dev/null @@ -1,37 +0,0 @@ -let - link "listutils.fn" as list; - - typedef sexpr { - atom(string) | - sexp(list(sexpr)) - } - - fn to_expr { - (atom("back")) { 1 } - (atom(['\'', c, '\''])) { 1 } - (atom("env")) { 1 } - (atom("error")) { 1 } - (atom(s)) { 1 } - (sexp([atom("amb"), a, b])) { 1 } - (sexp([atom("call/cc"), e])) { 1 } - (sexp([atom("if"), e1, e2, e3])) { 1 } - (sexp([atom("lambda"), sexp(args), body])) { 1 } - (sexp(atom("begin") @ exprs)) { 1 } - (sexp([atom("let"), sexp([e1, e2]), e3])) { 1 } - (sexp([atom("+"), e1, e2])) { 1 } - (sexp([atom("-"), e1, e2])) { 1 } - (sexp([atom("*"), e1, e2])) { 1 } - (sexp([atom("/"), e1, e2])) { 1 } - (sexp([atom("**"), e1, e2])) { 1 } - (sexp([atom("=="), e1, e2])) { 1 } - (sexp([atom("<"), e1, e2])) { 1 } - (sexp([atom(">"), e1, e2])) { 1 } - (sexp([atom("<="), e1, e2])) { 1 } - (sexp([atom(">="), e1, e2])) { 1 } - (sexp([atom("print"), e])) { 1 } - (sexp(func @ args)) { 1 } - (x) { 1 } - } - -in - 1; \ No newline at end of file diff --git a/tests/fn/bug_tpmc_comparison_order.fn b/tests/fn/bug_tpmc_comparison_order.fn index 2607e287..ba903205 100644 --- a/tests/fn/bug_tpmc_comparison_order.fn +++ b/tests/fn/bug_tpmc_comparison_order.fn @@ -18,7 +18,6 @@ fn test_simple_comparison() { in { assert(result1 == true); assert(result2 == false); - puts("test_simple_comparison passed\n"); true } } @@ -37,7 +36,6 @@ fn test_reverse_order() { in { assert(result1 == true); assert(result2 == false); - puts("test_reverse_order passed\n"); true } } @@ -57,7 +55,6 @@ fn test_adjacent_pairs() { in { assert(result1 == true); assert(result2 == false); - puts("test_adjacent_pairs passed\n"); true } } @@ -75,7 +72,6 @@ fn test_nested_comparison() { in { assert(result1 == true); assert(result2 == false); - puts("test_nested_comparison passed\n"); true } } @@ -93,7 +89,6 @@ fn test_triple_match() { in { assert(result1 == true); assert(result2 == false); - puts("test_triple_match passed\n"); true } } @@ -111,7 +106,6 @@ fn test_deep_nested() { in { assert(result1 == true); assert(result2 == false); - puts("test_deep_nested passed\n"); true } } @@ -132,7 +126,6 @@ fn test_list_comparison() { assert(result1 == true); assert(result2 == false); assert(result3 == false); - puts("test_list_comparison passed\n"); true } } @@ -150,7 +143,6 @@ fn test_first_and_third() { in { assert(result1 == true); assert(result2 == false); - puts("test_first_and_third passed\n"); true } } @@ -171,7 +163,6 @@ fn test_cons_comparison() { assert(result1 == true); assert(result2 == false); assert(result3 == false); - puts("test_cons_comparison passed\n"); true } } @@ -193,7 +184,6 @@ fn test_cross_comparison() { assert(result1 == true); assert(result2 == false); assert(result3 == false); - puts("test_cross_comparison passed\n"); true } } @@ -210,4 +200,3 @@ in test_cons_comparison(); test_cross_comparison(); - puts("TPMC comparison tests completed!\n"); diff --git a/tests/fn/fail_unify_assignment.fn b/tests/fn/fail_unify_assignment.fn new file mode 100644 index 00000000..3a4fb039 --- /dev/null +++ b/tests/fn/fail_unify_assignment.fn @@ -0,0 +1,7 @@ +let + fn test_fail_unify_assignment { + (x=#(1, x)) { true } + (_) { false } + } +in + 1; \ No newline at end of file diff --git a/tests/fn/import_data.fn b/tests/fn/import_data.fn new file mode 100644 index 00000000..6d805ec8 --- /dev/null +++ b/tests/fn/import_data.fn @@ -0,0 +1,2 @@ +namespace + fn data() { 1 } \ No newline at end of file diff --git a/tests/fn/test_over_application_nested.fn b/tests/fn/skip_test_over_application_nested.fn similarity index 96% rename from tests/fn/test_over_application_nested.fn rename to tests/fn/skip_test_over_application_nested.fn index 146a7cad..f270252f 100644 --- a/tests/fn/test_over_application_nested.fn +++ b/tests/fn/skip_test_over_application_nested.fn @@ -4,7 +4,7 @@ // f takes 2, returns g takes 2, returns h takes 1 // We call with 5 args at once, exercising nested staged over-application. let f = fn (a, b) { fn (c, d) { fn (e) { a + b + c + d + e } } }; - r = f(1, 2, 3, 4, 5); + r = f(1, 2)(3, 4)(5); in assert(r == 15); print("OA nested 1 passed: f(1,2,3,4,5) => 15"); diff --git a/tests/fn/stress_permute_number_ops.fn b/tests/fn/stress_permute_number_ops.fn index a01daf3d..56c36ffe 100644 --- a/tests/fn/stress_permute_number_ops.fn +++ b/tests/fn/stress_permute_number_ops.fn @@ -7,7 +7,6 @@ let link "listutils.fn" as lst; import lst operators; - operator "_|?_" left 8 fn (lst, f) { lst.filter(f, lst) }; fn genStdInts() { [4, 0, -4] diff --git a/tests/fn/test_adapter.fn b/tests/fn/test_adapter.fn index a02c5123..36ec2901 100644 --- a/tests/fn/test_adapter.fn +++ b/tests/fn/test_adapter.fn @@ -1,34 +1,30 @@ // Test automatic adapter generation for passing macros to higher-order functions let -macro lazy_or(a, b) { - puts("evaluating lazy_or\n"); +lazy fn lazy_or(a, b) { a or b } fn apply_binary(f, x, y) { - puts("apply_binary calling f\n"); f(fn () {x}, fn () {y}) } fn main() { - // Direct macro call - should work (already does) - puts("Direct call: "); + // Direct lazy fn call - should work (already does) { let result1 = lazy_or(true, false); in - print(result1); + assert(result1 == true); }; - // Pass macro to HOF - needs adapter + // Pass lazy fn to HOF - needs adapter { let result2 = apply_binary(lazy_or, true, false); in - puts("Through HOF (needs adapter): "); - print(result2); + assert(result2 == true); } } in - main(); \ No newline at end of file + main(); diff --git a/tests/fn/test_adapter_types.fn b/tests/fn/test_adapter_types.fn index 8da967a7..08e90931 100644 --- a/tests/fn/test_adapter_types.fn +++ b/tests/fn/test_adapter_types.fn @@ -1,7 +1,7 @@ // Test to see the types of lazy and adapter functions let - macro lazy_or(a, b) { + lazy fn lazy_or(a, b) { a or b } @@ -9,5 +9,5 @@ let lazy_or(x, y) } in - print(typeof lazy_or); - print(typeof strict_lazy_or); + assert((typeof lazy_or) == "#() -> bool -> #() -> bool -> bool"); + assert((typeof strict_lazy_or) == "bool -> bool -> bool"); \ No newline at end of file diff --git a/tests/fn/test_amb_backtracking.fn b/tests/fn/test_amb_backtracking.fn index 5deb88a9..2282eb20 100644 --- a/tests/fn/test_amb_backtracking.fn +++ b/tests/fn/test_amb_backtracking.fn @@ -12,7 +12,6 @@ let result = 1 then 2 then 3; in assert(result == 1); - puts("Basic then test passed\n") } // Test: Backtracking with back @@ -27,7 +26,6 @@ let result = try_values(); in assert(result == 2); - puts("Simple backtrack test passed\n") } // Test: Multiple backtracking points @@ -47,7 +45,6 @@ let result = find_pair(); in assert(result == #(2, 20)); - puts("Multiple backtrack test passed\n") } // Test: Nested backtracking @@ -69,7 +66,6 @@ let result = outer(); in assert(result == #(1, 10)); - puts("Nested backtrack test passed\n") } // Test: Backtracking with lists @@ -88,7 +84,6 @@ let result = find_in_list(); in assert(result == 2); - puts("List backtrack test passed\n") } // Test: amb with require @@ -105,7 +100,6 @@ let result = find_valid(); in assert(result == 3); - puts("Amb require test passed\n") } // Test: Backtracking exhaustion @@ -125,7 +119,6 @@ let result = safe_try(); in assert(result == 999); - puts("Backtrack exhaustion test passed\n") } // Test: amb.integers_from @@ -142,7 +135,6 @@ let result = find_square(); in assert(result == 11); - puts("Integers from test passed\n") } // Test: amb.integers_between @@ -158,7 +150,6 @@ let result = find_in_range(); in assert(result == 12); - puts("Integers between test passed\n") } // Test: Complex constraint satisfaction @@ -177,7 +168,6 @@ let result = find_triple(); in assert(result == #(3, #(4, 5))); - puts("Complex constraints test passed\n") } // Test: Backtracking with pattern matching @@ -200,7 +190,6 @@ let result = find_valid_pair(); in assert(result == #(3, 4)); - puts("Pattern match backtrack test passed\n") } // Test: Backtracking preserves state @@ -216,7 +205,6 @@ let result = compute(); in assert(result == 20); - puts("State preservation test passed\n") } // Test: Deep backtracking chain @@ -241,7 +229,6 @@ let result = level1(); in assert(result == 120); - puts("Deep backtrack test passed\n") } // Test: Backtracking with recursion @@ -261,7 +248,6 @@ let result = find_sum(30, [10, 20, 30, 40]); in assert(result == 10); - puts("Recursive backtrack test passed\n") } // Test: amb choice with functions @@ -283,7 +269,6 @@ let result = find_transform(); in assert(result == 15); - puts("Amb functions test passed\n") } // Main test runner @@ -303,7 +288,6 @@ let test_deep_backtrack(); test_recursive_backtrack(); test_amb_functions(); - puts("All amb/backtracking tests completed successfully\n") } in diff --git a/tests/fn/test_ambutils_complete.fn b/tests/fn/test_ambutils_complete.fn index 5a49e4e2..548ff650 100644 --- a/tests/fn/test_ambutils_complete.fn +++ b/tests/fn/test_ambutils_complete.fn @@ -11,11 +11,6 @@ let let result = amb.some_of([1, 2]); in // some_of generates subsets, so result should be a list - print typeof result; - print list.length(typeof result) - print "list(number)"; - print list.length("list(number)"); - assert("list(number)" == "list(number)"); assert(typeof result == "list(number)") } @@ -106,4 +101,3 @@ in test_some_of_operator(); test_combined_amb(); - puts("All ambutils tests completed successfully!") diff --git a/tests/fn/test_arithmetic_edge_cases.fn b/tests/fn/test_arithmetic_edge_cases.fn index c9aff2e2..a2309413 100644 --- a/tests/fn/test_arithmetic_edge_cases.fn +++ b/tests/fn/test_arithmetic_edge_cases.fn @@ -156,4 +156,3 @@ in test_multiplication_edges(); test_arithmetic_comparisons(); test_chained_operations(); - puts("All arithmetic edge case tests completed successfully!") diff --git a/tests/fn/test_arithmetic_mixed_types.fn b/tests/fn/test_arithmetic_mixed_types.fn index 516cc4aa..4302ccee 100644 --- a/tests/fn/test_arithmetic_mixed_types.fn +++ b/tests/fn/test_arithmetic_mixed_types.fn @@ -515,4 +515,3 @@ in test_power_float_imaginary_float(); - puts("All mixed-type arithmetic tests passed!\n") diff --git a/tests/fn/test_backtracking_advanced.fn b/tests/fn/test_backtracking_advanced.fn index cc82000d..b7f33cd0 100644 --- a/tests/fn/test_backtracking_advanced.fn +++ b/tests/fn/test_backtracking_advanced.fn @@ -295,4 +295,3 @@ in test_then_in_calls(); test_backtrack_arithmetic(); - puts("All advanced backtracking tests passed!\n") diff --git a/tests/fn/test_bespoke_comparator.fn b/tests/fn/test_bespoke_comparator.fn new file mode 100644 index 00000000..8e628684 --- /dev/null +++ b/tests/fn/test_bespoke_comparator.fn @@ -0,0 +1,46 @@ +let + typedef term { + add(term, term) | + sub(term, term) | + mul(term, term) | + div(term, term) | + pow(term, term) | + num(number) | + var(string) + } + + EQ term { + (add(a, b), add(a, b)) | + (add(b, a), add(a, b)) | + (sub(a, b), sub(a, b)) | + (mul(a, b), mul(a, b)) | + (mul(b, a), mul(a, b)) | + (div(a, b), div(a, b)) | + (pow(a, b), pow(a, b)) | + (num(a), num(a)) | + (var(a), var(a)) { true } + (_, _) { false } + } + + fn fold { + (sub(a, a)) { num(0) } + (add(a, a)) { mul(num(2), a) } + (add(a, sub(num(0), a))) { num(0) } + (add(sub(num(0), a), a)) { num(0) } + (x) { x } + } +in + // Test non-matching patterns return original + assert(fold(sub(num(5), num(3))) == sub(num(5), num(3))); + // Test that sub-patterns use bespoke semantic equality + assert(fold(sub(mul(var("x"), var("y")), mul(var("x"), var("y")))) + == num(0)); + assert(fold(sub(mul(var("x"), var("y")), mul(var("y"), var("x")))) + == num(0)); + assert(fold(add(mul(var("x"), var("y")), mul(var("x"), var("y")))) + == mul(num(2), mul(var("x"), var("y")))); + assert(fold(add(mul(var("x"), var("y")), mul(var("y"), var("x")))) + == mul(num(2), mul(var("x"), var("y")))); + assert(fold(add(var("x"), sub(num(0), var("x")))) == num(0)); + assert(mul(var("x"), var("y")) == mul(var("y"), var("x"))); + assert(mul(var("x"), mul(var("y"), var("z"))) == mul(mul(var("z"), var("y")), var("x"))); \ No newline at end of file diff --git a/tests/fn/test_bigint_edge_cases.fn b/tests/fn/test_bigint_edge_cases.fn index b909ae04..994bcd60 100644 --- a/tests/fn/test_bigint_edge_cases.fn +++ b/tests/fn/test_bigint_edge_cases.fn @@ -15,7 +15,6 @@ let assert(sum == 1111111110); assert(diff == 864197532); assert(prod == 121932631112635269); - puts("Basic bigint test passed\n") } // Test: Very large numbers @@ -28,7 +27,6 @@ let in assert(sum == 1888888888888888887); assert(prod == 1999999999999999998); - puts("Large numbers test passed\n") } // Test: Negative big integers @@ -42,7 +40,6 @@ let assert(neg < 0); assert(sum == 0); assert(prod < 0); - puts("Negative bigint test passed\n") } // Test: Big integer division returns rationals @@ -55,7 +52,6 @@ let // 1000000000 / 3 returns "1000000000/3" not 333333333 // Only test exact divisions that result in integers assert(a / b == 10); - puts("Bigint division test passed\n") } // Test: Big integer modulo @@ -68,7 +64,6 @@ let assert(a % b == 6); assert(a % c == 12); assert(100 % 3 == 1); - puts("Bigint modulo test passed\n") } // Test: Big integer power @@ -81,7 +76,6 @@ let assert(a == 100000); assert(b == 1024); assert(c == 6561); - puts("Bigint power test passed\n") } // Test: Big integer comparisons @@ -97,7 +91,6 @@ let assert(a >= c); assert(a <= c); assert(a != b); - puts("Bigint comparisons test passed\n") } // Test: Factorial with big integers @@ -116,7 +109,6 @@ let assert(fact5 == 120); assert(fact10 == 3628800); assert(fact15 == 1307674368000); - puts("Factorial bigint test passed\n") } // Test: Fibonacci with big integers @@ -135,7 +127,6 @@ let assert(f10 == 55); assert(f15 == 610); assert(f20 == 6765); - puts("Fibonacci bigint test passed\n") } // Test: Sum of list with big integers @@ -154,7 +145,6 @@ let in assert(sum1 == 6000000); assert(sum2 == 1666666665); - puts("List sum bigint test passed\n") } // Test: GCD with big integers @@ -170,7 +160,6 @@ let in assert(result1 == 50000); assert(result2 == 9); - puts("GCD bigint test passed\n") } // Test: Powers of 2 @@ -183,7 +172,6 @@ let assert(p10 == 1024); assert(p20 == 1048576); assert(p30 == 1073741824); - puts("Powers of two test passed\n") } // Test: Powers of 10 @@ -198,7 +186,6 @@ let assert(p6 == 1000000); assert(p9 == 1000000000); assert(p12 == 1000000000000); - puts("Powers of ten test passed\n") } // Test: Mixed operations @@ -215,7 +202,6 @@ let assert(result1 == 3750); assert(result2 == 5025); assert(result3 == 2500); - puts("Mixed operations test passed\n") } // Test: Zero operations @@ -228,7 +214,6 @@ let assert(b - a == b); assert(a * b == 0); assert(a ** 10 == 0); - puts("Zero operations test passed\n") } // Main test runner @@ -248,7 +233,6 @@ let test_powers_of_ten(); test_mixed_operations(); test_zero_operations(); - puts("All bigint tests completed successfully!") } in diff --git a/tests/fn/test_builtin_incr.fn b/tests/fn/test_builtin_incr.fn index 7f9141cc..cb0df15c 100644 --- a/tests/fn/test_builtin_incr.fn +++ b/tests/fn/test_builtin_incr.fn @@ -3,7 +3,7 @@ let b = incr(); c = incr(); in - print typeof incr; + assert(typeof incr == "#() -> number"); assert(a == 1); assert(b == 2); assert(c == 3); \ No newline at end of file diff --git a/tests/fn/test_builtin_unicode.fn b/tests/fn/test_builtin_unicode.fn index 5120e89d..67744857 100644 --- a/tests/fn/test_builtin_unicode.fn +++ b/tests/fn/test_builtin_unicode.fn @@ -48,4 +48,3 @@ assert(unicode_category('\uE000;') == GC_Co); // Private Use Area assert(unicode_category('\uD800;') == GC_Cs); // High Surrogate // GC_Cn (Unassigned) test - using a code point that is currently unassigned assert(unicode_category('\u0378;') == GC_Ll); // Lowecase letter -puts("Unicode category tests passed\n") \ No newline at end of file diff --git a/tests/fn/test_builtins_argv.fn b/tests/fn/test_builtins_argv.fn index c8561496..2a58492c 100644 --- a/tests/fn/test_builtins_argv.fn +++ b/tests/fn/test_builtins_argv.fn @@ -11,7 +11,7 @@ let let arg0 = argv(0); in switch(arg0) { - (some(val)) { + (just(val)) { // If we have an argument, it should be a string (list of chars) assert(typeof val == "list(char)"); // It should have some length @@ -32,7 +32,7 @@ let in switch(arg100) { (nothing) { assert(true) } // Expected for high index - (some(_)) { assert(true) } // Also ok if many args provided + (just(_)) { assert(true) } // Also ok if many args provided } } @@ -42,7 +42,7 @@ let a1 = argv(1); a2 = argv(2); in - // All should return either some or nothing + // All should return either just or nothing // Just verify the pattern works assert(true) } @@ -54,7 +54,7 @@ let // Negative indices should return nothing switch(arg_neg) { (nothing) { assert(true) } - (some(_)) { assert(true) } // Implementation dependent + (just(_)) { assert(true) } // Implementation dependent } } @@ -64,4 +64,3 @@ in test_multiple_indices(); test_negative_index(); - puts("All argv() tests completed successfully!") diff --git a/tests/fn/test_builtins_directory.fn b/tests/fn/test_builtins_directory.fn index d799b827..0ce9a54c 100644 --- a/tests/fn/test_builtins_directory.fn +++ b/tests/fn/test_builtins_directory.fn @@ -63,4 +63,3 @@ in test_opendir_file(); test_opendir_empty(); - puts("All directory operation tests completed successfully!") diff --git a/tests/fn/test_builtins_env.fn b/tests/fn/test_builtins_env.fn index 890f31cc..1bb5ad1c 100644 --- a/tests/fn/test_builtins_env.fn +++ b/tests/fn/test_builtins_env.fn @@ -10,7 +10,7 @@ let let home = getenv("HOME"); in switch(home) { - (some(val)) { + (just(val)) { // Should be a string (list of chars) assert(typeof val == "list(char)"); // Should have some length (path is not empty) @@ -32,7 +32,7 @@ let in switch(nonexist) { (nothing) { assert(true) } // Expected - (some(_)) { + (just(_)) { // Very unlikely someone set this variable // but not an error assert(true) @@ -45,7 +45,7 @@ let let path = getenv("PATH"); in switch(path) { - (some(val)) { + (just(val)) { assert(typeof val == "list(char)"); assert(list.length(val) > 0); true @@ -64,7 +64,7 @@ let in switch(empty) { (nothing) { assert(true) } // Expected for empty name - (some(_)) { assert(true) } // Also acceptable + (just(_)) { assert(true) } // Also acceptable } } @@ -86,4 +86,3 @@ in test_getenv_empty(); test_multiple_getenv(); - puts("All getenv() tests completed successfully!") diff --git a/tests/fn/test_builtins_ftype.fn b/tests/fn/test_builtins_ftype.fn index 3383da31..20f5c886 100644 --- a/tests/fn/test_builtins_ftype.fn +++ b/tests/fn/test_builtins_ftype.fn @@ -88,4 +88,3 @@ in test_ftype_empty(); test_ftype_current_dir(); - puts("All ftype() tests completed successfully!") diff --git a/tests/fn/test_builtins_rand.fn b/tests/fn/test_builtins_rand.fn index ce86ba6b..02c2326f 100644 --- a/tests/fn/test_builtins_rand.fn +++ b/tests/fn/test_builtins_rand.fn @@ -116,4 +116,3 @@ in test_reproducibility(); test_various_seeds(); - puts("All rand() tests completed successfully!") diff --git a/tests/fn/test_closures_advanced.fn b/tests/fn/test_closures_advanced.fn index d8c4e7ef..df8de1fc 100644 --- a/tests/fn/test_closures_advanced.fn +++ b/tests/fn/test_closures_advanced.fn @@ -358,4 +358,3 @@ in test_closure_with_conditional(); test_closure_lifetime(); - puts("All advanced closure tests passed!\n") diff --git a/tests/fn/test_comparisons_complete.fn b/tests/fn/test_comparisons_complete.fn index 95ceaf60..f12562da 100644 --- a/tests/fn/test_comparisons_complete.fn +++ b/tests/fn/test_comparisons_complete.fn @@ -186,4 +186,3 @@ in test_comparison_conditionals(); test_tuple_comparisons(); test_pattern_equality(); - puts("All comparison tests completed successfully!") diff --git a/tests/fn/test_continuations_advanced.fn b/tests/fn/test_continuations_advanced.fn index da8fdda1..47ce4935 100644 --- a/tests/fn/test_continuations_advanced.fn +++ b/tests/fn/test_continuations_advanced.fn @@ -304,4 +304,3 @@ in test_continuation_unused(); test_continuation_string(); - puts("All advanced continuation tests passed!\n") diff --git a/tests/fn/test_control_flow.fn b/tests/fn/test_control_flow.fn index 8eed33a9..6111e41a 100644 --- a/tests/fn/test_control_flow.fn +++ b/tests/fn/test_control_flow.fn @@ -171,4 +171,3 @@ in test_boolean_expressions(); test_comparison_conditions(); test_switch_chars(); - puts("All control flow tests completed successfully!") diff --git a/tests/fn/test_control_flow_complete.fn b/tests/fn/test_control_flow_complete.fn index 60654989..177867d6 100644 --- a/tests/fn/test_control_flow_complete.fn +++ b/tests/fn/test_control_flow_complete.fn @@ -435,4 +435,3 @@ in test_and_short_circuit(); test_or_short_circuit(); - puts("All control flow tests passed!\n") diff --git a/tests/fn/test_convergence.fn b/tests/fn/test_convergence.fn index 6745dd4c..d728e40a 100644 --- a/tests/fn/test_convergence.fn +++ b/tests/fn/test_convergence.fn @@ -1,14 +1,12 @@ // Test to observe how many passes are needed for type convergence -print("Testing convergence in various scenarios:"); -print(""); - { // Simple case - should converge quickly let f = fn(x) { x + 1 }; g = fn(y) { f(y) * 2 }; in - print("Simple forward ref: " @@ typeof f @@ ", " @@ typeof g); + assert(typeof f == "number -> number"); + assert(typeof g == "number -> number"); }; { @@ -16,7 +14,8 @@ in let isEven = fn(n) { if (n == 0) { true } else { isOdd(n - 1) } }; isOdd = fn(n) { if (n == 0) { false } else { isEven(n - 1) } }; in - print("Mutual recursion: " @@ typeof isEven @@ ", " @@ typeof isOdd); + assert(typeof isEven == "number -> bool"); + assert(typeof isOdd == "number -> bool"); }; { @@ -29,7 +28,7 @@ let makeAdder = fn (x) { }; multiplier = fn () { 10 }; in - print("Complex forward refs: " @@ typeof makeAdder); + assert(typeof makeAdder == "number -> number -> number"); }; { @@ -38,8 +37,7 @@ let a = fn (n) { if (n == 0) { 0 } else { b(n - 1) + 1 } }; b = fn (n) { if (n == 0) { 1 } else { c(n - 1) + 2 } }; c = fn (n) { if (n == 0) { 2 } else { a(n - 1) + 3 } }; in - print("Three-way recursion: " @@ typeof a @@ ", " @@ typeof b @@ ", " @@ typeof c); + assert(typeof a == "number -> number"); + assert(typeof b == "number -> number"); + assert(typeof c == "number -> number"); }; - -print(""); -print("All convergence tests completed."); diff --git a/tests/fn/test_currentfile.fn b/tests/fn/test_currentfile.fn index 078ef5c3..30b3680a 100644 --- a/tests/fn/test_currentfile.fn +++ b/tests/fn/test_currentfile.fn @@ -9,7 +9,4 @@ let in { assert(currentFile == expectedFile); - puts("currentFile is: "); - puts(currentFile); - puts("\n"); } diff --git a/tests/fn/test_currentline.fn b/tests/fn/test_currentline.fn index d1ad4e80..80342d3e 100644 --- a/tests/fn/test_currentline.fn +++ b/tests/fn/test_currentline.fn @@ -14,5 +14,4 @@ in { // Test that currentLine works in expressions assert(currentLine == 15); - puts("currentLine tests passed!\n"); } diff --git a/tests/fn/test_curry.fn b/tests/fn/test_curry.fn index c7079efd..799eb00e 100644 --- a/tests/fn/test_curry.fn +++ b/tests/fn/test_curry.fn @@ -20,15 +20,8 @@ in assert(test_curry(2, add(3)) == 5); unsafe switch(makeWriter()) { (success(#(fp, fg))) { - puts("Testing curried fput:\n"); fp("Hello, "); fp("world!\n"); - puts(typeof fp); - puts("\n"); - puts(typeof fg); - puts("\n"); - puts(fg()); - puts("Testing curried fput done\n"); - assert(true) + assert(fg() == "Hello, world!\n"); } - } \ No newline at end of file + } diff --git a/tests/fn/test_currying_complete.fn b/tests/fn/test_currying_complete.fn index e1d2f87f..13512793 100644 --- a/tests/fn/test_currying_complete.fn +++ b/tests/fn/test_currying_complete.fn @@ -263,4 +263,3 @@ in test_chain_partial(); test_multiple_branches(); - puts("All currying tests passed!\n") diff --git a/tests/fn/test_error_handling.fn b/tests/fn/test_error_handling.fn index f6f4ce42..1ab1fcb9 100644 --- a/tests/fn/test_error_handling.fn +++ b/tests/fn/test_error_handling.fn @@ -35,7 +35,7 @@ let if (b == 0) { nothing } else { - some(a / b) + just(a / b) } }; in unsafe switch(safe_div(10, 0)) { @@ -49,7 +49,7 @@ let if (b == 0) { nothing } else { - some(a / b) + just(a / b) } }; in unsafe switch(safe_div(1/2, 0)) { @@ -63,7 +63,7 @@ let if (b == 0) { nothing } else { - some(a % b) + just(a % b) } }; in unsafe switch(safe_mod(10, 0)) { @@ -77,7 +77,7 @@ let let safe_foldl1 = fn(func, lst) { switch(lst) { ([]) { nothing } - (h @ t) { some(list.foldl(func, h, t)) } + (h @ t) { just(list.foldl(func, h, t)) } } }; in unsafe switch(safe_foldl1(fn(a,b){a+b}, [])) { @@ -86,7 +86,7 @@ let // Test with non-empty list for comparison unsafe switch(safe_foldl1(fn(a,b){a+b}, [1,2,3])) { - (some(result)) { assert(result == 6) } + (just(result)) { assert(result == 6) } } } @@ -97,7 +97,7 @@ let if (idx < 0 or idx >= list.length(lst)) { nothing } else { - some(list.nth(idx, lst)) + just(list.nth(idx, lst)) } }; in @@ -113,7 +113,7 @@ let // Valid index unsafe switch(safe_nth(1, [1,2,3])) { - (some(val)) { assert(val == 2) } + (just(val)) { assert(val == 2) } } } @@ -123,7 +123,7 @@ let let safe_last = fn(lst) { switch(lst) { ([]) { nothing } - (_) { some(list.last(lst)) } + (_) { just(list.last(lst)) } } }; in @@ -132,7 +132,7 @@ let }; unsafe switch(safe_last([1,2,3])) { - (some(val)) { assert(val == 3) } + (just(val)) { assert(val == 3) } } } @@ -141,13 +141,13 @@ let let safe_minimum = fn(lst) { switch(lst) { ([]) { nothing } - (_) { some(list.minimum(lst)) } + (_) { just(list.minimum(lst)) } } }; safe_maximum = fn(lst) { switch(lst) { ([]) { nothing } - (_) { some(list.maximum(lst)) } + (_) { just(list.maximum(lst)) } } }; in @@ -162,11 +162,11 @@ let // Non-empty cases unsafe switch(safe_minimum([3,1,2])) { - (some(val)) { assert(val == 1) } + (just(val)) { assert(val == 1) } }; unsafe switch(safe_maximum([3,1,2])) { - (some(val)) { assert(val == 3) } + (just(val)) { assert(val == 3) } } } @@ -259,7 +259,7 @@ let if (b == 0 + 0i) { nothing } else { - some(a / b) + just(a / b) } }; in @@ -274,7 +274,7 @@ let // Valid complex division unsafe switch(safe_complex_div(6 + 8i, 2)) { - (some(result)) { assert(result == 3 + 4i) } + (just(result)) { assert(result == 3 + 4i) } } } @@ -338,7 +338,7 @@ let let #(a, b, c) = #(1, 2, 3); safe_unpack = fn(t) { switch(t) { - (#(x, y)) { some(x + y) } + (#(x, y)) { just(x + y) } (_) { nothing } } }; @@ -347,7 +347,7 @@ let // Safe unpacking with switch unsafe switch(safe_unpack(#(1, 2))) { - (some(val)) { assert(val == 3) } + (just(val)) { assert(val == 3) } }; // Wrong arity would be caught at compile time @@ -398,4 +398,3 @@ in test_tuple_unpacking(); test_character_edge_cases(); - puts("All error handling tests completed successfully!\n") diff --git a/tests/fn/test_generics_typedefs.fn b/tests/fn/test_generics_typedefs.fn index 529dc83a..c7d7355d 100644 --- a/tests/fn/test_generics_typedefs.fn +++ b/tests/fn/test_generics_typedefs.fn @@ -23,7 +23,6 @@ let assert(unwrap_or(int_maybe, 0) == 42); assert(unwrap_or(str_maybe, "default") == "hello"); assert(unwrap_or(none, 99) == 99); - puts("Basic generics tests passed\n") } // Test: Nested generic types @@ -50,7 +49,6 @@ let mapped = map_maybe(fn { (inner) { map_maybe(double, inner) } }, nested); in assert(mapped == just(just(10))); - puts("Nested generics tests passed\n") } // Test: Generic list operations @@ -84,7 +82,6 @@ let assert(length(list_of_lists) == 3); assert(append([1, 2], [3, 4]) == [1, 2, 3, 4]); assert(reverse([1, 2, 3]) == [3, 2, 1]); - puts("Generic list tests passed\n") } // Test: Multiple type parameters @@ -116,7 +113,6 @@ let assert(snd(p2) == 99); assert(fst(swapped) == "hello"); assert(snd(swapped) == 42); - puts("Multiple type parameter tests passed\n") } // Test: Generic tree structure @@ -154,7 +150,6 @@ let in assert(sum == 15); assert(tree_fold(add, 0, doubled_tree) == 30); - puts("Generic tree tests passed\n") } // Test: Either type (like result) @@ -184,7 +179,6 @@ let in assert(unwrap_right(mapped_r) == 20); assert(mapped_l == left("error")); - puts("Either type tests passed\n") } // Test: Recursive generic types @@ -212,9 +206,6 @@ let in assert(mylist_length(list) == 3); assert(mylist_length(doubled) == 3); - putv(mylist_length(list)); - putv(mylist_length(doubled)); - puts("done") } // Test: Polymorphic identity and const @@ -230,7 +221,6 @@ let assert(const(5, 10) == 5); assert(const("a", "b") == "a"); assert(apply(id, 100) == 100); - puts("Polymorphic function tests passed\n") } // Test: Complex nested pattern matching @@ -261,7 +251,6 @@ let assert(find_leftmost(tree2) == 10); assert(count_leaves(tree1) == 4); assert(count_leaves(tree2) == 3); - puts("Complex pattern matching tests passed\n") } // Main test runner @@ -275,7 +264,6 @@ let test_recursive_generics(); test_polymorphic_functions(); test_complex_patterns(); - puts("All generic/typedef tests completed successfully!") } in diff --git a/tests/fn/test_higher_order_functions.fn b/tests/fn/test_higher_order_functions.fn index 798de8c5..d1ee9d65 100644 --- a/tests/fn/test_higher_order_functions.fn +++ b/tests/fn/test_higher_order_functions.fn @@ -39,7 +39,6 @@ let assert(doubled == [2, 4, 6, 8, 10]); assert(evens == [2, 4]); assert(sum == 15); - puts("Map/Filter/Fold tests passed\n") } // Test: Closures capturing variables @@ -67,7 +66,6 @@ let assert(add10(7) == 17); assert(counter(1) == 101); assert(counter(5) == 105); - puts("Closure tests passed\n") } // Test: Nested closures @@ -91,7 +89,6 @@ let in assert(mult2_3(4) == 24); assert(mult2_5(4) == 40); - puts("Nested closure tests passed\n") } // Test: Function composition @@ -114,7 +111,6 @@ let assert(double_then_square(3) == 36); assert(square_then_double(3) == 18); assert(inc_then_double(5) == 12); - puts("Function composition tests passed\n") } // Test: Currying @@ -144,7 +140,6 @@ let assert(add5(7) == 12); assert(mult3(4) == 12); assert(mult3(10) == 30); - puts("Currying tests passed\n") } // Test: Partial application @@ -166,7 +161,6 @@ let assert(sub10(7) == 3); assert(div100(10) == 10); assert(div100(5) == 20); - puts("Partial application tests passed\n") } // Test: Functions returning functions @@ -200,7 +194,6 @@ let assert(is_percentage(0)); assert(is_percentage(100)); assert(not is_percentage(101)); - puts("Function factory tests passed\n") } // Test: Higher-order functions with multiple parameters @@ -227,7 +220,6 @@ let assert(twice(double, 3) == 12); assert(apply_n(inc, 5, 0) == 5); assert(apply_n(double, 3, 2) == 16); - puts("Complex higher-order function tests passed\n") } // Test: Closure variable capture edge cases @@ -253,7 +245,6 @@ let in assert(add_func(10) == 15); assert(mult_func(10) == 60); - puts("Closure capture tests passed\n") } // Main test runner @@ -267,7 +258,6 @@ let test_function_factories(); test_complex_higher_order(); test_closure_capture(); - puts("All higher-order function tests completed successfully!") } in diff --git a/tests/fn/test_import_data.fn b/tests/fn/test_import_data.fn new file mode 100644 index 00000000..a564ce7f --- /dev/null +++ b/tests/fn/test_import_data.fn @@ -0,0 +1,4 @@ +let + link "import_data.fn" as Data; +in + assert(Data.data() == 1); \ No newline at end of file diff --git a/tests/fn/test_import_hygiene_collisions.fn b/tests/fn/test_import_hygiene_collisions.fn index cb83051d..22a7d85d 100644 --- a/tests/fn/test_import_hygiene_collisions.fn +++ b/tests/fn/test_import_hygiene_collisions.fn @@ -16,4 +16,3 @@ in assert(2 plus 3 == 5); assert(~5 == -5); - puts("Hygiene with collisions OK\n") diff --git a/tests/fn/test_import_nested_shadowing.fn b/tests/fn/test_import_nested_shadowing.fn index d0e81c98..20362b17 100644 --- a/tests/fn/test_import_nested_shadowing.fn +++ b/tests/fn/test_import_nested_shadowing.fn @@ -22,4 +22,3 @@ in // After inner scope, shadowing is gone; outer imported plus remains; operator ~_ is not visible here assert(2 plus 3 == 5); - puts("Nested import/shadowing OK\n") diff --git a/tests/fn/test_import_op_conflict.fn b/tests/fn/test_import_op_conflict.fn index 2ee8e6e6..5c09fcc0 100644 --- a/tests/fn/test_import_op_conflict.fn +++ b/tests/fn/test_import_op_conflict.fn @@ -18,20 +18,5 @@ let // Test infix operator - should call ifx.subtract test_infix = 10 - 3; in - { - // Print results - puts("test_prefix (expected -5): "); - putn(test_prefix); - puts("\n"); - - puts("test_infix (expected 7): "); - putn(test_infix); - puts("\n"); - - // Both should work correctly with their respective namespace implementations - if (test_prefix == -5 and test_infix == 7) { - puts("PASS\n") - } else { - puts("FAIL\n") - } - } + // Both should work correctly with their respective namespace implementations + assert(test_prefix == -5 and test_infix == 7) diff --git a/tests/fn/test_import_operators_selective.fn b/tests/fn/test_import_operators_selective.fn index c18505d9..184daf75 100644 --- a/tests/fn/test_import_operators_selective.fn +++ b/tests/fn/test_import_operators_selective.fn @@ -9,5 +9,3 @@ in assert(~5 == -5); assert(3 plus 4 == 7); - // We did not import the Postfix; don't use it here (negative tests handled elsewhere) - puts("Selective operator import OK\n") diff --git a/tests/fn/test_lazy_complete.fn b/tests/fn/test_lazy_complete.fn index 1cb29367..2b0fa0f4 100644 --- a/tests/fn/test_lazy_complete.fn +++ b/tests/fn/test_lazy_complete.fn @@ -6,25 +6,21 @@ // === Macros (lazy functions) === let -macro lazy_and(a, b) { - puts("lazy_and evaluated\n"); +lazy fn lazy_and(a, b) { a and b } -macro lazy_or(a, b) { - puts("lazy_or evaluated\n"); +lazy fn lazy_or(a, b) { a or b } // === Strict functions === fn strict_and(x, y) { - puts("strict_and evaluated\n"); x and y } fn strict_or(x, y) { - puts("strict_or evaluated\n"); x or y } @@ -41,41 +37,22 @@ fn adapt_lazy_or(x, y) { // === Higher-order function === fn apply_binary(f, x, y) { - puts("apply_binary calling function\n"); f(x, y) } in // === Type Display === -puts("=== Type Display Tests ===\n"); -puts("lazy_and type: "); -print(typeof lazy_and); -puts("lazy_or type: "); -print(typeof lazy_or); -puts("strict_and type: "); -print(typeof strict_and); -puts("strict_or type: "); -print(typeof strict_or); -puts("adapt_lazy_and: "); -print(typeof adapt_lazy_and); -puts("\n"); +assert((typeof lazy_and) == "#() -> bool -> #() -> bool -> bool"); +assert((typeof lazy_or) == "#() -> bool -> #() -> bool -> bool"); +assert((typeof strict_and) == "bool -> bool -> bool"); +assert((typeof strict_or) == "bool -> bool -> bool"); +assert((typeof adapt_lazy_and) == "bool -> bool -> bool"); +assert((typeof adapt_lazy_or) == "bool -> bool -> bool"); // === Main tests === -puts("=== Direct Calls (all work) ===\n"); -puts("lazy_and(true, false): "); -print(lazy_and(true, false)); -puts("strict_and(true, false): "); -print(strict_and(true, false)); -puts("\n"); +assert(lazy_and(true, false) == false); +assert(strict_and(true, false) == false); -puts("=== Through HOF ===\n"); -puts("Strict function through HOF: "); -print(apply_binary(strict_or, true, false)); +assert(apply_binary(strict_or, true, false) == true); -puts("\nAdapter through HOF: "); -print(apply_binary(adapt_lazy_or, true, false)); - -puts("\n=== SUCCESS ===\n"); -puts("Phase 1 & 2 complete!\n"); -puts("- Types correctly track laziness\n"); -puts("- Manual adapters work perfectly\n"); +assert(apply_binary(adapt_lazy_or, true, false) == true); diff --git a/tests/fn/test_lazy_types.fn b/tests/fn/test_lazy_types.fn index 91492a6a..a5bfbf4c 100644 --- a/tests/fn/test_lazy_types.fn +++ b/tests/fn/test_lazy_types.fn @@ -1,12 +1,9 @@ // Test that macros are typed with lazy arguments -print("Testing lazy function types:"); -print(""); - { let // Define a simple macro - macro lazy_or(a, b) { + lazy fn lazy_or(a, b) { a or b } @@ -18,22 +15,12 @@ let lazy_type = typeof lazy_or; strict_type = typeof strict_or; in - print("lazy_or type: " @@ typeof lazy_or); - print("strict_or type: " @@ typeof strict_or); - print(""); + assert(lazy_type == "#() -> bool -> #() -> bool -> bool"); + assert(strict_type == "bool -> bool -> bool"); // Both should work when called normally assert(lazy_or(true, false) == true); assert(strict_or(true, false) == true); - print("Direct calls work"); - print(""); - print("Lazy type has (#()) markers: " @@ lazy_type); - print("Strict type is normal: " @@ strict_type); - // They should be different assert(lazy_type != strict_type); - print("Types are correctly different"); }; - -print(""); -print("Lazy type tracking tests passed\n"); diff --git a/tests/fn/test_lists_complete.fn b/tests/fn/test_lists_complete.fn index a2690fe2..2c26578d 100644 --- a/tests/fn/test_lists_complete.fn +++ b/tests/fn/test_lists_complete.fn @@ -359,4 +359,3 @@ in test_nested_equality(); test_concat_chains(); - puts("All list tests passed!\n") diff --git a/tests/fn/test_listutils_complete.fn b/tests/fn/test_listutils_complete.fn index ba62b7c7..b630cfe8 100644 --- a/tests/fn/test_listutils_complete.fn +++ b/tests/fn/test_listutils_complete.fn @@ -144,4 +144,3 @@ in test_sortBy_strings(); test_combined_operations(); - puts("All listutils tests completed successfully!") diff --git a/tests/fn/test_logic_complete.fn b/tests/fn/test_logic_complete.fn index 72e47b82..7cb00c66 100644 --- a/tests/fn/test_logic_complete.fn +++ b/tests/fn/test_logic_complete.fn @@ -308,4 +308,3 @@ in test_mixed_chaining(); test_with_comparisons(); - puts("All logic tests passed!\n") diff --git a/tests/fn/test_macros.fn b/tests/fn/test_macros.fn index c91e0f23..d945d672 100644 --- a/tests/fn/test_macros.fn +++ b/tests/fn/test_macros.fn @@ -3,59 +3,55 @@ let - // Test: Basic macro definition and use + // Test: Basic lazy fn definition and use fn test_basic_macro() { let - macro DOUBLE(x) { x + x } + lazy fn DOUBLE(x) { x + x } result = DOUBLE(5); in assert(result == 10); - puts("Basic macro test passed\n") } // Test: Macro with multiple arguments fn test_multi_arg_macro() { let - macro ADD(a, b) { a + b } - macro MULT(a, b) { a * b } + lazy fn ADD(a, b) { a + b } + lazy fn MULT(a, b) { a * b } sum = ADD(3, 4); product = MULT(5, 6); in assert(sum == 7); assert(product == 30); - puts("Multi-argument macro test passed\n") } // Test: Macro argument evaluation (should be lazy) fn test_macro_lazy_eval() { let - macro FIRST(a, b) { a } + lazy fn FIRST(a, b) { a } fn explode() { back } result = FIRST(42, explode()) then 999; in assert(result == 42); - puts("Macro lazy evaluation test passed\n") } - // Test: Nested macro calls + // Test: Nested lazy fn calls fn test_nested_macros() { let - macro DOUBLE(x) { x + x } - macro QUAD(x) { DOUBLE(DOUBLE(x)) } + lazy fn DOUBLE(x) { x + x } + lazy fn QUAD(x) { DOUBLE(DOUBLE(x)) } result = QUAD(3); in assert(result == 12); - puts("Nested macro test passed\n") } // Test: Macro with conditional fn test_macro_conditional() { let - macro MAX(a, b) { + lazy fn MAX(a, b) { if (a > b) { a } else { b } } @@ -64,26 +60,24 @@ let in assert(result1 == 10); assert(result2 == 8); - puts("Macro conditional test passed\n") } // Test: Macro with explicit parameters (not variable capture) fn test_macro_parameters() { let - macro ADD_TEN(y) { 10 + y } + lazy fn ADD_TEN(y) { 10 + y } result1 = ADD_TEN(5); result2 = ADD_TEN(15); in assert(result1 == 15); assert(result2 == 25); - puts("Macro parameters test passed\n") } // Test: Macro with pattern matching fn test_macro_pattern() { let - macro HEAD(lst) { + lazy fn HEAD(lst) { switch (lst) { ([]) { back } (h @ dummy) { h } @@ -93,7 +87,6 @@ let result = HEAD([1, 2, 3]); in assert(result == 1); - puts("Macro pattern matching test passed\n") } // Test: Macro with function calls @@ -102,33 +95,31 @@ let fn double { (x) { x * 2 } } fn triple { (x) { x * 3 } } - macro APPLY_BOTH(f, g, x) { + lazy fn APPLY_BOTH(f, g, x) { f(x) + g(x) } result = APPLY_BOTH(double, triple, 5); in assert(result == 25); - puts("Macro function calls test passed\n") } // Test: Macro with list operations fn test_macro_list_ops() { let - macro CONS_TWICE(x, lst) { + lazy fn CONS_TWICE(x, lst) { x @ x @ lst } result = CONS_TWICE(5, [1, 2, 3]); in assert(result == [5, 5, 1, 2, 3]); - puts("Macro list operations test passed\n") } // Test: Short-circuit AND macro fn test_short_circuit_and() { let - macro AND(a, b) { + lazy fn AND(a, b) { if (a) { b } else { false } } @@ -139,13 +130,12 @@ let in assert(result1 == false); assert(result2 == true); - puts("Short-circuit AND test passed\n") } // Test: Short-circuit OR macro fn test_short_circuit_or() { let - macro OR(a, b) { + lazy fn OR(a, b) { if (a) { true } else { b } } @@ -156,13 +146,12 @@ let in assert(result1 == true); assert(result2 == true); - puts("Short-circuit OR test passed\n") } // Test: Macro with recursion fn test_macro_recursion() { let - macro APPLY_TWICE(f, x) { + lazy fn APPLY_TWICE(f, x) { f(f(x)) } @@ -171,13 +160,12 @@ let result = APPLY_TWICE(inc, 5); in assert(result == 7); - puts("Macro recursion test passed\n") } - // Test: Complex macro expression + // Test: Complex lazy fn expression fn test_complex_macro() { let - macro COMPUTE(a, b, c) { + lazy fn COMPUTE(a, b, c) { let sum = a + b; prod = sum * c; @@ -188,17 +176,16 @@ let result = COMPUTE(2, 3, 4); in assert(result == 20); - puts("Complex macro test passed\n") } // Test: Macro with tuple fn test_macro_tuple() { let - macro MAKE_PAIR(a, b) { + lazy fn MAKE_PAIR(a, b) { #(a, b) } - macro SWAP_PAIR(p) { + lazy fn SWAP_PAIR(p) { switch (p) { (#(x, y)) { #(y, x) } } @@ -209,7 +196,6 @@ let in assert(pair == #(1, 2)); assert(swapped == #(2, 1)); - puts("Macro tuple test passed\n") } // Test: Macro argument used multiple times @@ -219,33 +205,31 @@ let let x = 1 then 2 then 3; in x } - macro USE_TWICE(x) { + lazy fn USE_TWICE(x) { #(x, x) } result = USE_TWICE(counter()); in assert(result == #(1, 1)); - puts("Macro multi-use test passed\n") } // Test: Macro with let binding shadowing argument fn test_macro_arg_shadowing() { let - macro SHADOW_ARG(x) { + lazy fn SHADOW_ARG(x) { let x = 100; in x + 1 } result = SHADOW_ARG(42); in assert(result == 101); // Should use shadowed x=100, not argument - puts("Macro argument shadowing test passed\n") } // Test: Macro with nested let shadowing fn test_macro_nested_shadow() { let - macro NESTED_SHADOW(a, b) { + lazy fn NESTED_SHADOW(a, b) { let a = 10; in { @@ -259,13 +243,12 @@ let result = NESTED_SHADOW(1, 2); in assert(result == 30); // Should use shadowed values 10 and 20 - puts("Macro nested shadowing test passed\n") } // Test: Macro argument partially shadowed fn test_macro_partial_shadow() { let - macro PARTIAL_SHADOW(x, y) { + lazy fn PARTIAL_SHADOW(x, y) { let x = 5; in @@ -275,13 +258,12 @@ let result = PARTIAL_SHADOW(100, 200); in assert(result == 205); // 5 (shadowed x) + 200 (original y) - puts("Macro partial shadowing test passed\n") } // Test: Macro with let binding using argument fn test_macro_let_using_arg() { let - macro LET_WITH_ARG(x) { + lazy fn LET_WITH_ARG(x) { let y = x; // Simple assignment to force evaluation z = y + 10; @@ -292,31 +274,29 @@ let result = LET_WITH_ARG(5); in assert(result == 30); // (5 + 10) * 2 - puts("Macro let using argument test passed\n") } // Test: Macro with multiple let bindings and shadowing - // Tests that macro parameter 'a' can be shadowed in let binding + // Tests that lazy fn parameter 'a' can be shadowed in let binding fn test_macro_multiple_lets() { let - macro MULTI_LET(a) { + lazy fn MULTI_LET(a) { let val_a = a; // Use original 'a' b = val_a + 1; a = b + 1; // Shadow 'a' - this should work in - a + b // Uses shadowed 'a', not macro parameter + a + b // Uses shadowed 'a', not lazy fn parameter } result = MULTI_LET(10); in assert(result == 23); // a=12, b=11, sum=23 - puts("Macro multiple lets test passed\n") } // Test: Macro with deeply nested let and argument access fn test_macro_deep_let_nesting() { let - macro DEEP_NEST(x) { + lazy fn DEEP_NEST(x) { let a = x; in { @@ -338,13 +318,12 @@ let result = DEEP_NEST(5); in assert(result == 13); // d=8 (5+1+1+1), d+x = 8+5 - puts("Macro deep let nesting test passed\n") } // Test: Macro with function definition shadowing argument fn test_macro_fn_shadow() { let - macro FN_SHADOW(x) { + lazy fn FN_SHADOW(x) { let fn x() { 999 } in @@ -354,13 +333,12 @@ let result = FN_SHADOW(42); in assert(result == 999); // Function x shadows argument x - puts("Macro function shadowing test passed\n") } // Test: Macro with pattern match shadowing fn test_macro_pattern_shadow() { let - macro PATTERN_SHADOW(x) { + lazy fn PATTERN_SHADOW(x) { unsafe switch ([1, 2, 3]) { (x @ rest) { x + >=_" right 100 andThen; fn maybePlus(ma, mb) { - ma >>= fn(a) { mb >>= fn(b) { some(a + b) } } + ma >>= fn(a) { mb >>= fn(b) { just(a + b) } } } fn safeDiv { (a, 0) { nothing } - (a, b) { some(a / b) } + (a, b) { just(a / b) } } fn maybeDiv (ma, mb) { ma >>= fn(a) { mb >>= fn(b) { safeDiv(a, b) } } } in - assert(maybePlus(some(5), some(10)) == some(15)); - assert(maybePlus(some(5), nothing) == nothing); - assert(maybePlus(nothing, some(10)) == nothing); + assert(maybePlus(just(5), just(10)) == just(15)); + assert(maybePlus(just(5), nothing) == nothing); + assert(maybePlus(nothing, just(10)) == nothing); assert(maybePlus(nothing, nothing) == nothing); - assert(maybePlus(some(5), maybeDiv(some(15), some(3))) == some(10)); - assert(maybePlus(some(5), maybeDiv(some(15), some(0))) == nothing); + assert(maybePlus(just(5), maybeDiv(just(15), just(3))) == just(10)); + assert(maybePlus(just(5), maybeDiv(just(15), just(0))) == nothing); diff --git a/tests/fn/test_multi_unification.fn b/tests/fn/test_multi_unification.fn new file mode 100644 index 00000000..b15d0689 --- /dev/null +++ b/tests/fn/test_multi_unification.fn @@ -0,0 +1,80 @@ +// Test cases for multi-occurrence pseudo-unification (3+ occurrences) + +let + fn lst { + ([a, a, a]) { 0 } + (_) { 1 } + } + + fn triple { + (a, a, a) { 0 } + (_, _, _) { 1 } + } + + fn quad { + (a, a, a, a) { 0 } + (_, _, _, _) { 1 } + } + + fn quint { + (a, a, a, a, a) { 42 } + (_, _, _, _, _) { 99 } + } + + fn two_pairs { + (a, a, b, b) { 0 } + (_, _, _, _) { 1 } + } + + typedef nested { nested(number, number, number) } + + fn nested_triple { + (nested(a, a, a)) { 0 } + (_) { 1 } + } + + typedef tree { + leaf(number) | + node(tree, number, tree) + } + + fn all_same_tree { + (node(leaf(a), a, leaf(a))) { true } + (_) { false } + } + +in + assert(lst([5, 5, 5]) == 0); + assert(lst([5, 5, 6]) == 1); + + assert(triple(5, 5, 5) == 0); + assert(triple(5, 5, 6) == 1); + assert(triple(5, 6, 5) == 1); + assert(triple(6, 5, 5) == 1); + + assert(quad(3, 3, 3, 3) == 0); + assert(quad(3, 3, 3, 4) == 1); + assert(quad(3, 4, 3, 3) == 1); + + assert(quint(7, 7, 7, 7, 7) == 42); + assert(quint(7, 7, 7, 7, 8) == 99); + + assert(two_pairs(1, 1, 2, 2) == 0); + assert(two_pairs(1, 1, 1, 1) == 0); + assert(two_pairs(1, 2, 2, 2) == 1); + assert(two_pairs(1, 1, 2, 3) == 1); + + assert(nested_triple(nested(5, 5, 5)) == 0); + assert(nested_triple(nested(5, 5, 6)) == 1); + assert(nested_triple(nested(5, 6, 5)) == 1); + assert(nested_triple(nested(6, 5, 5)) == 1); + + assert(all_same_tree(node(leaf(5), 5, leaf(5)))); + assert(not(all_same_tree(node(leaf(5), 6, leaf(5))))); + assert(not(all_same_tree(node(leaf(5), 5, leaf(6))))); + + assert(triple('x', 'x', 'x') == 0); + assert(triple('x', 'y', 'x') == 1); + + assert(triple([1,2], [1,2], [1,2]) == 0); + assert(triple([1,2], [1,3], [1,2]) == 1); diff --git a/tests/fn/test_namespaces_linking.fn b/tests/fn/test_namespaces_linking.fn index dccfa00a..c160786b 100644 --- a/tests/fn/test_namespaces_linking.fn +++ b/tests/fn/test_namespaces_linking.fn @@ -27,7 +27,6 @@ let assert(listutils2.length([100, 200]) == 2); // prove that a namespace is only really imported once assert(listutils.length == listutils2.length); // yes you can - puts("Imported list functions test passed\n") } // Test: Using map from imported module @@ -39,7 +38,6 @@ let in assert(doubled == [2, 4, 6]); assert(squared == [1, 4, 9]); - puts("Imported map test passed\n") } // Test: Using filter from imported module @@ -53,7 +51,6 @@ let assert(evens == [2, 4, 6]); assert(odds == [1, 3, 5]); assert(large == [4, 5, 6]); - puts("Imported filter test passed\n") } // Test: Using amb utilities @@ -72,7 +69,6 @@ let result = test_one_of(); in assert(result == 2); - puts("Imported amb test passed\n") } // Test: Chaining imported functions @@ -88,7 +84,6 @@ let assert(evens == [2, 4, 6, 8, 10]); assert(doubled == [4, 8, 12, 16, 20]); assert(sum == 60); - puts("Chaining imported functions test passed\n") } // Test: Nested use of imported functions @@ -107,7 +102,6 @@ let in assert(lengths == [2, 2, 2]); assert(doubled_lists == [[2, 4], [6, 8], [10, 12]]); - puts("Nested imported functions test passed\n") } // Test: Higher-order functions with imports @@ -123,7 +117,6 @@ let result = listutils.map(add5, list1); in assert(result == [6, 7, 8, 9, 10]); - puts("Higher-order with imports test passed\n") } // Test: Composition with imported functions @@ -142,7 +135,6 @@ let result = listutils.map(double_then_inc, list1); in assert(result == [3, 5, 7]); - puts("Composition with imports test passed\n") } // Main test runner @@ -155,7 +147,6 @@ let test_nested_imported(); test_higher_order_with_imports(); test_composition_with_imports(); - puts("All namespace and linking tests completed successfully!\n") } in diff --git a/tests/fn/test_negative_rational.fn b/tests/fn/test_negative_rational.fn index 8a068672..cbc5a43d 100644 --- a/tests/fn/test_negative_rational.fn +++ b/tests/fn/test_negative_rational.fn @@ -2,4 +2,4 @@ let lhs = 2; rhs = -4/4; in - print lhs ** rhs; \ No newline at end of file + assert(lhs ** rhs == 1/2); \ No newline at end of file diff --git a/tests/fn/test_operator_hygiene.fn b/tests/fn/test_operator_hygiene.fn index 779bae7e..3ba1ce29 100644 --- a/tests/fn/test_operator_hygiene.fn +++ b/tests/fn/test_operator_hygiene.fn @@ -63,7 +63,6 @@ in assert(triple 10 == 30) }; - puts("All operator hygiene tests passed!\n") diff --git a/tests/fn/test_operator_hygiene_full.fn b/tests/fn/test_operator_hygiene_full.fn index 949a9920..6c32f8f3 100644 --- a/tests/fn/test_operator_hygiene_full.fn +++ b/tests/fn/test_operator_hygiene_full.fn @@ -232,7 +232,6 @@ fn main () { test_shadow_restoration(); test_nested_function_scope(); - puts("All operator hygiene tests passed!\n") } in main() diff --git a/tests/fn/test_operator_kw.fn b/tests/fn/test_operator_kw.fn index 7bb6c6c8..8b7260de 100644 --- a/tests/fn/test_operator_kw.fn +++ b/tests/fn/test_operator_kw.fn @@ -1,7 +1,7 @@ let link "import_operator_kw.fn" as ops; - macro CONDITIONAL(test, consequent, alternative) { + lazy fn CONDITIONAL(test, consequent, alternative) { fn { (true) { consequent } (false) { alternative } diff --git a/tests/fn/test_operators_edge_cases.fn b/tests/fn/test_operators_edge_cases.fn index 36501337..d477d44e 100644 --- a/tests/fn/test_operators_edge_cases.fn +++ b/tests/fn/test_operators_edge_cases.fn @@ -18,7 +18,6 @@ let assert(a == 7); assert(b == 30); assert(c == 49); - puts("Basic custom operators test passed\n") } // Test: Operator precedence @@ -32,7 +31,6 @@ let assert(result1 == 14); assert(result2 == (2 times 3) plus 4); assert(result2 == 10); - puts("Operator precedence test passed\n") } // Test: Postfix operators @@ -43,7 +41,6 @@ let in assert(a == 25); assert(b == 25); - puts("Postfix operators test passed\n") } // Test: Left associativity @@ -55,7 +52,6 @@ let in // Left assoc: (10 - 3) - 2 = 5 assert(result == 5); - puts("Left associativity test passed\n") } // Test: Right associativity @@ -67,7 +63,6 @@ let in // Right assoc: 2 ** (3 ** 2) = 2 ** 9 = 512 assert(result == 512); - puts("Right associativity test passed\n") } // Test: Operator shadowing in nested scopes @@ -84,7 +79,6 @@ let inner = 3 foo 4; in assert(inner == 12); - puts("Operator shadowing test passed\n") } } @@ -101,7 +95,6 @@ let assert(result1 == 5); assert(result2 == 8); assert(result3 == 8); - puts("Operators with expressions test passed\n") } // Test: Operators with lists @@ -114,7 +107,6 @@ let in assert(list1 == [1, 2, 3, 4]); assert(list2 == [1, 2, 3]); - puts("Operators with lists test passed\n") } // Test: Built-in operator precedence @@ -127,7 +119,6 @@ let assert(result1 == 14); assert(result2 == 4); assert(result3 == 9); - puts("Built-in precedence test passed\n") } // Test: Comparison operators @@ -142,7 +133,6 @@ let assert(a <= 5); assert(a == 5); assert(a != b); - puts("Comparison operators test passed\n") } // Test: Logical operators (from preamble) @@ -155,7 +145,6 @@ let assert(not (t and f)); assert(t or f); assert(not (f or f)); - puts("Logical operators test passed\n") } // Test: Cons operator @@ -168,7 +157,6 @@ let assert(list1 == [1, 2, 3]); assert(list2 == [1, 2, 3]); assert(list3 == [1, 2, 3]); - puts("Cons operator test passed\n") } // Test: Append operator @@ -179,7 +167,6 @@ let in assert(list1 == [1, 2, 3, 4]); assert(list2 == [1, 2, 3]); - puts("Append operator test passed\n") } // Main test runner @@ -197,7 +184,6 @@ let test_logical_operators(); test_cons_operator(); test_append_operator(); - puts("All operator tests completed successfully\n") } in diff --git a/tests/fn/test_operators_macros_advanced.fn b/tests/fn/test_operators_macros_advanced.fn index 35aa1ef1..960640c7 100644 --- a/tests/fn/test_operators_macros_advanced.fn +++ b/tests/fn/test_operators_macros_advanced.fn @@ -1,5 +1,5 @@ -// Advanced operator and macro tests -// Testing: custom operators, precedence, associativity, macro hygiene +// Advanced operator and lazy fn tests +// Testing: custom operators, precedence, associativity, lazy fn hygiene let // Test basic custom infix operator @@ -75,7 +75,7 @@ let } // Test basic macro - macro DOUBLE(x) { x + x } + lazy fn DOUBLE(x) { x + x } fn test_basic_macro() { let @@ -86,8 +86,8 @@ let } } - // Test macro with multiple arguments - macro MAX(a, b) { if (a > b) { a } else { b } } + // Test lazy fn with multiple arguments + lazy fn MAX(a, b) { if (a > b) { a } else { b } } fn test_macro_multiple_args() { let @@ -98,8 +98,8 @@ let } } - // Test macro with conditional - macro IF_THEN(cond, val) { if (cond) { val } else { 0 } } + // Test lazy fn with conditional + lazy fn IF_THEN(cond, val) { if (cond) { val } else { 0 } } fn test_macro_conditional() { let @@ -110,8 +110,8 @@ let } } - // Test macro with operator - macro AND(a, b) { if (a) { b } else { false } } + // Test lazy fn with operator + lazy fn AND(a, b) { if (a) { b } else { false } } operator "_and_" left 30 AND; fn test_macro_operator() { @@ -194,8 +194,8 @@ let } } - // Test macro with recursion - macro FACT(n) { if (n <= 1) { 1 } else { n * FACT(n - 1) } } + // Test lazy fn with recursion + lazy fn FACT(n) { if (n <= 1) { 1 } else { n * FACT(n - 1) } } fn test_macro_recursion() { let @@ -237,4 +237,3 @@ in test_macro_recursion(); test_operator_string(); - puts("All advanced operator and macro tests passed!\n") diff --git a/tests/fn/test_over_application.fn b/tests/fn/test_over_application.fn index 3ff50c1f..f9ced441 100644 --- a/tests/fn/test_over_application.fn +++ b/tests/fn/test_over_application.fn @@ -1,40 +1,27 @@ // Over-application tests (enhanced diagnostics) let - link "../../fn/ioutils.fn" as io; - operator "$_" 15 io.to_string; + link "ioutils.fn" as io; + import io operator "$_"; + fun1 = fn (x, y) { fn (z) { x + y + z } }; + r1 = fun1(1, 2, 3); + fun2 = fn (a, b) { fn (c) { fn(d) { a + b + c + d } } }; + r2 = fun2(1, 2, 3, 4); + g = fn (x) { fn (y) { fn (z) { x + y + z } } }; + multAdd = fn (x, y) { fn (z) { x * y + z } }; + r3 = multAdd(2, 5, 3); in -{ - // Direct lambda application (not via let-binding) to exercise compiler split - let - fun1 = fn (x, y) { fn (z) { x + y + z } }; - r1 = fun1(1, 2, 3); - in - print("typeof fun1: " @@ typeof fun1); - print("result fun1(1,2,3): " @@ $r1); - assert(r1 == 6); - print("Test OA1 passed: direct lambda m=2, n=3 => 6"); -}; -{ - // Another direct lambda with two extra args to ensure APPLY 2; APPLY 1; APPLY 1 - let fun2 = fn (a, b) { fn (c) { fn(d) { a + b + c + d } } }; - r2 = fun2(1, 2, 3, 4); - in + print("typeof fun1: " @@ typeof fun1); + print("result fun1(1,2,3): " @@ $r1); + assert(r1 == 6); + print("Test OA1 passed: direct lambda m=2, n=3 => 6"); print("typeof fun2: " @@ typeof fun2); print("result fun2(1,2,3,4): " @@ $r2); assert(r2 == 10); print("Test OA2 passed: direct lambda m=2, n=4 => 10"); -}; -{ - // Mixed sanity checks (no over-application for g) - let g = fn (x) { fn (y) { fn (z) { x + y + z } } }; - multAdd = fn (x, y) { fn (z) { x * y + z } }; - r3 = multAdd(2, 5, 3); - in print("typeof g: " @@ typeof g); assert(g(1, 2, 3) == 6); print("typeof multAdd: " @@ typeof multAdd); print("result multAdd(2,5,3): " @@ $r3); assert(r3 == 13); print("Test OA3 passed: mixed cases (sanity checks)"); -}; diff --git a/tests/fn/test_parser_fn_digit_identifier.fn b/tests/fn/test_parser_fn_digit_identifier.fn index 3b2e103b..cd2338f8 100644 --- a/tests/fn/test_parser_fn_digit_identifier.fn +++ b/tests/fn/test_parser_fn_digit_identifier.fn @@ -10,4 +10,3 @@ let result = fn3(1, 2, 3); in assert(result == 6); - puts("Fixed: fn followed by digit should be valid identifier\n") diff --git a/tests/fn/test_parser_semi_6.fn b/tests/fn/test_parser_semi_6.fn index 04847ab7..403140b1 100644 --- a/tests/fn/test_parser_semi_6.fn +++ b/tests/fn/test_parser_semi_6.fn @@ -1,10 +1,11 @@ // Test: statements with multiple sequential semicolons let + fn id(x) { x } a = 1; b = 2; c = 3 in { - puts("one");; - puts("two");;; - puts("three") + assert(id("one") == "one");; + assert(id("two") == "two");;; + assert(id("three") == "three") } diff --git a/tests/fn/test_pattern_matching.fn b/tests/fn/test_pattern_matching.fn index be633604..f65b03ef 100644 --- a/tests/fn/test_pattern_matching.fn +++ b/tests/fn/test_pattern_matching.fn @@ -5,7 +5,7 @@ let // Define test types typedef tree(#t) { leaf | node(#t, tree(#t), tree(#t)) } - typedef option(#t) { none | some(#t) } + typedef option(#t) { none | just(#t) } typedef result(#ok, #err) { ok(#ok) | err(#err) } @@ -66,17 +66,17 @@ let // Test option type patterns fn test_option_patterns() { - let opt1 = some(42); + let opt1 = just(42); opt2 = none; in switch (opt1) { (none) { assert(false) } - (some(x)) { assert(x == 42) } + (just(x)) { assert(x == 42) } }; switch (opt2) { (none) { assert(true) } - (some(_)) { assert(false) } + (just(_)) { assert(false) } }; true } @@ -186,4 +186,3 @@ in test_string_patterns(); test_wildcards(); test_pattern_assignment(); - puts("All pattern matching tests completed successfully!") diff --git a/tests/fn/test_pattern_matching_deep.fn b/tests/fn/test_pattern_matching_deep.fn index da11248b..1fe31e59 100644 --- a/tests/fn/test_pattern_matching_deep.fn +++ b/tests/fn/test_pattern_matching_deep.fn @@ -496,4 +496,3 @@ in test_char_pattern(); test_string_pattern(); - puts("All deep pattern matching tests passed!\n") diff --git a/tests/fn/test_print_complete.fn b/tests/fn/test_print_complete.fn index 12d8754c..a6c17ed2 100644 --- a/tests/fn/test_print_complete.fn +++ b/tests/fn/test_print_complete.fn @@ -241,4 +241,3 @@ in test_print_list_edge_cases(); test_print_char_list(); - puts("All print system tests passed!\n") diff --git a/tests/fn/test_pseudo_unification.fn b/tests/fn/test_pseudo_unification.fn index c03e8d6a..8289d702 100644 --- a/tests/fn/test_pseudo_unification.fn +++ b/tests/fn/test_pseudo_unification.fn @@ -7,4 +7,3 @@ let in assert(contains("dummy", [1, 2, 3, 4], 3) == true); assert(contains("dummy", [1, 2, 3, 4], 5) == false); - puts("Bug pseudo-unification test passed\n") \ No newline at end of file diff --git a/tests/fn/test_rational_arithmetic.fn b/tests/fn/test_rational_arithmetic.fn index 78569d66..65c9baba 100644 --- a/tests/fn/test_rational_arithmetic.fn +++ b/tests/fn/test_rational_arithmetic.fn @@ -14,7 +14,6 @@ let assert(r1 == 10 / 3); assert(r2 == 7 / 2); assert(r3 == 25); // Simplified to integer - puts("Basic rationals test passed\n") } // Test: Rational equality @@ -28,7 +27,6 @@ let assert(r1 == r2); assert(r1 == r3); assert(r2 == r3); - puts("Rational equality test passed\n") } // Test: Rational addition @@ -40,7 +38,6 @@ let expected = 5 / 6; in assert(sum == expected); - puts("Rational addition test passed\n") } // Test: Rational subtraction @@ -51,7 +48,6 @@ let diff = r1 - r2; in assert(diff == 1 / 2); - puts("Rational subtraction test passed\n") } // Test: Rational multiplication @@ -62,7 +58,6 @@ let prod = r1 * r2; in assert(prod == 1 / 2); - puts("Rational multiplication test passed\n") } // Test: Rational division @@ -73,7 +68,6 @@ let quot = r1 / r2; in assert(quot == 2); - puts("Rational division test passed\n") } // Test: Mixed integer and rational arithmetic @@ -86,7 +80,6 @@ let in assert(sum == 21 / 2); assert(prod == 5); - puts("Mixed arithmetic test passed\n") } // Test: Negative rationals @@ -99,7 +92,6 @@ let assert(r1 < 0); assert(r2 < 0); assert(sum == (0 - 5) / 4); - puts("Negative rationals test passed\n") } // Test: Rational comparisons @@ -115,7 +107,6 @@ let assert(r1 >= r3); assert(r1 <= r3); assert(r1 != r2); - puts("Rational comparisons test passed\n") } // Test: Large rational numbers @@ -126,7 +117,6 @@ let diff = r1 - r2; in assert(diff == 1 / 3); - puts("Large rationals test passed\n") } // Test: Rational powers @@ -138,7 +128,6 @@ let in assert(r2 == 1 / 4); assert(r3 == 1 / 8); - puts("Rational powers test passed\n") } // Test: Zero in rationals @@ -150,7 +139,6 @@ let assert(zero_num == 0); assert(r + zero_num == r); assert(r * zero_num == 0); - puts("Zero rationals test passed\n") } // Test: Simplification @@ -163,7 +151,6 @@ let assert(r1 == r3); assert(r2 == r3); assert(r1 == r2); - puts("Simplification test passed\n") } // Test: Rational to integer when whole @@ -176,7 +163,6 @@ let assert(r1 == 5); assert(r2 == 25); assert(r3 == 7); - puts("Rational to integer test passed\n") } // Main test runner @@ -195,7 +181,6 @@ let test_zero_rationals(); test_simplification(); test_rational_to_integer(); - puts("All rational arithmetic tests completed successfully!") } in diff --git a/tests/fn/test_readdir_segfault.fn b/tests/fn/test_readdir_segfault.fn index 28fd405f..6eab7be0 100644 --- a/tests/fn/test_readdir_segfault.fn +++ b/tests/fn/test_readdir_segfault.fn @@ -16,7 +16,7 @@ let in closedir(dirhandle); switch(entry) { - (some(name)) { + (just(name)) { // Should get a filename string assert(typeof name == "list(char)"); assert(list.length(name) > 0); @@ -56,7 +56,5 @@ let } in - puts("Testing readdir() - may segfault..."); test_readdir_basic(); test_readdir_multiple(); - puts("If you see this, readdir() has been fixed!") diff --git a/tests/fn/test_recursion_edge_cases.fn b/tests/fn/test_recursion_edge_cases.fn index c187a437..5583005a 100644 --- a/tests/fn/test_recursion_edge_cases.fn +++ b/tests/fn/test_recursion_edge_cases.fn @@ -19,7 +19,6 @@ let assert(result1 == 120); assert(result2 == 3628800); assert(result3 == 1); - puts("Tail recursion tests passed\n") } } @@ -39,7 +38,6 @@ let assert(result1 == 120); assert(result2 == 3628800); assert(result3 == 1); - puts("Non-tail recursion tests passed\n") } } @@ -64,7 +62,6 @@ let assert(not is_even(5)); assert(is_even(100)); assert(is_odd(99)); - puts("Mutual recursion tests passed\n") } // Test: Nested recursion @@ -85,7 +82,6 @@ let assert(result2 == 4); assert(result3 == 7); assert(result4 == 29); - puts("Nested recursion (Ackermann) tests passed\n") } // Test: Recursion with list processing @@ -118,7 +114,6 @@ let assert(reversed == [5, 4, 3, 2, 1]); assert(empty_sum == 0); assert(empty_product == 1); - puts("List recursion tests passed\n") } // Test: Recursion with multiple arguments @@ -138,7 +133,6 @@ let assert(result2 == 25); assert(result3 == 1); assert(result4 == 5); - puts("Multi-argument recursion tests passed\n") } // Test: Deep recursion stress test (Fibonacci) @@ -160,7 +154,6 @@ let assert(fib(10) == 55); assert(fib(15) == 610); assert(fib(20) == 6765); - puts("Fibonacci recursion tests passed\n") } // Test: Recursion with pattern matching complexity @@ -206,7 +199,6 @@ let assert(single_depth == 1); assert(empty_sum == 0); assert(empty_depth == 0); - puts("Recursive pattern matching tests passed\n") } // Main test runner @@ -219,7 +211,6 @@ let test_multi_arg_recursion(); test_fibonacci(); test_recursive_patterns(); - puts("All recursion tests completed successfully!") } in main(); diff --git a/tests/fn/test_scoping_complete.fn b/tests/fn/test_scoping_complete.fn index e83f06d9..cdd80892 100644 --- a/tests/fn/test_scoping_complete.fn +++ b/tests/fn/test_scoping_complete.fn @@ -351,4 +351,3 @@ in test_shadow_tuple(); test_function_shadow(); - puts("All scoping tests passed!\n") diff --git a/tests/fn/test_setutils.fn b/tests/fn/test_setutils.fn index 93c25c29..7576d07c 100644 --- a/tests/fn/test_setutils.fn +++ b/tests/fn/test_setutils.fn @@ -12,7 +12,6 @@ let assert(1 IN s); assert(3 IN s); assert(not 6 IN s); - puts("test_contains passed\n"); true; } @@ -27,7 +26,6 @@ let assert(3 IN su); assert(4 IN su); assert(5 IN su); - puts("test_union passed\n"); true; } @@ -43,7 +41,6 @@ let assert(4 IN si); assert(not 5 IN si); assert(not 6 IN si); - puts("test_intersection passed\n"); true; } @@ -59,7 +56,6 @@ let assert(not 4 IN sd); assert(not 5 IN sd); assert(not 6 IN sd); - puts("test_difference 1 passed\n"); true; } @@ -75,7 +71,6 @@ let assert(not 4 IN sd); assert(5 IN sd); assert(6 IN sd); - puts("test_difference 2 passed\n"); true; } @@ -85,4 +80,3 @@ in test_intersection(); test_difference1(); test_difference2(); - puts("All SET tests passed\n"); \ No newline at end of file diff --git a/tests/fn/test_simple_lazy.fn b/tests/fn/test_simple_lazy.fn deleted file mode 100644 index 07e09c27..00000000 --- a/tests/fn/test_simple_lazy.fn +++ /dev/null @@ -1,15 +0,0 @@ -// Simpler test for lazy macro types - -{ -let - macro m(x) { x } -in - print("macro m type: " @@ typeof m); -}; - -{ -let - fn f(x) { x } -in - print("function f type: " @@ typeof f); -}; diff --git a/tests/fn/test_sqlite.fn b/tests/fn/test_sqlite.fn index f80be769..b8886289 100644 --- a/tests/fn/test_sqlite.fn +++ b/tests/fn/test_sqlite.fn @@ -10,5 +10,5 @@ in let name = dict.lookup("name", row); in - assert(name == some(basic_string("EGYPTIAN HIEROGLYPH AA018"))); + assert(name == just(basic_string("EGYPTIAN HIEROGLYPH AA018"))); })))); diff --git a/tests/fn/test_strings_complete.fn b/tests/fn/test_strings_complete.fn index 4af2fabb..d8e0fa4f 100644 --- a/tests/fn/test_strings_complete.fn +++ b/tests/fn/test_strings_complete.fn @@ -163,4 +163,3 @@ in test_string_patterns(); test_long_strings(); test_mixed_content(); - puts("All string tests completed successfully!") diff --git a/tests/fn/test_strings_escapes.fn b/tests/fn/test_strings_escapes.fn index 33a0bfac..7ad9afbd 100644 --- a/tests/fn/test_strings_escapes.fn +++ b/tests/fn/test_strings_escapes.fn @@ -327,4 +327,3 @@ in test_string_in_tuple(); test_case_sensitivity(); - puts("All string escape and edge case tests passed!\n") diff --git a/tests/fn/test_tc.fn b/tests/fn/test_tc.fn index 405c2424..0e563b21 100644 --- a/tests/fn/test_tc.fn +++ b/tests/fn/test_tc.fn @@ -20,7 +20,6 @@ in // These should all have correct types assert(typeof isEven == "number -> bool"); assert(typeof isOdd == "number -> bool"); - print("Test 1 passed: Simple mutual recursion"); }; { // Test 2: Mutual recursion with type propagation @@ -41,7 +40,6 @@ let foo = fn (x) { in assert(typeof foo == "number -> number"); assert(typeof bar == "number -> number"); - print("Test 2 passed: Mutual recursion with arithmetic"); }; { // Test 3: Three-way mutual recursion @@ -70,7 +68,6 @@ in assert(typeof a == "number -> number"); assert(typeof b == "number -> number"); assert(typeof c == "number -> number"); - print("Test 3 passed: Three-way mutual recursion"); }; { // Test 4: Mutual recursion with lists @@ -89,7 +86,6 @@ let mapEven = fn (lst) { in assert(typeof mapEven == "list(number) -> list(number)"); assert(typeof mapOdd == "list(number) -> list(number)"); - print("Test 4 passed: Mutual recursion with lists"); }; { // Test 5: Zero-argument functions (thunks) in forward references @@ -101,13 +97,9 @@ let makeAdder = fn (x) { }; multiplier = fn () { 10 }; in - print("makeAdder type: " @@ typeof makeAdder); - print("useMultiplier type: " @@ typeof useMultiplier); - print("multiplier type: " @@ typeof multiplier); assert(typeof makeAdder == "number -> number -> number"); assert(typeof multiplier == "#() -> number"); // Thunk type assert(typeof useMultiplier == "number -> number"); - print("Test 5 passed: Higher-order functions with thunks"); }; { // Test 6: Polymorphic mutual recursion @@ -127,11 +119,8 @@ let polyA = fn (x, pred) { }; in // Both should have the same polymorphic type - print("polyA type: " @@ typeof polyA); - print("polyB type: " @@ typeof polyB); // Check they work with numbers assert(polyA(5, fn(n){n > 3}) == 5); - print("Test 6 passed: Polymorphic mutual recursion"); }; { // Test 7: Self-reference with complex type @@ -145,29 +134,15 @@ let factorial = fn (n) { in assert(typeof factorial == "number -> number"); assert(factorial(5) == 120); - print("Test 7 passed: Self-recursive function"); }; { // Test 8: Zero-argument functions as thunks let multiplier = fn () { 10 }; getDefault = fn () { 0 }; in - print("multiplier type: " @@ typeof multiplier); - print("getDefault type: " @@ typeof getDefault); // Zero-argument functions are typed as thunks assert(typeof multiplier == "#() -> number"); assert(typeof getDefault == "#() -> number"); assert(multiplier() == 10); assert(getDefault() == 0); - print("Test 8 passed: Zero-argument functions work as thunks"); -}; -print(""); -print("Type checker test summary:"); -print("- Tests 1-4: PASSED (mutual recursion works)"); -print("- Test 5: PASSED (zero-arg functions work as thunks)"); -print("- Test 6: PASSED (polymorphic mutual recursion works)"); -print("- Test 7: PASSED (self-recursion works)"); -print("- Test 8: PASSED (zero-arg functions as thunks)"); -print(""); -print("All type checker tests PASSED!"); - +}; \ No newline at end of file diff --git a/tests/fn/test_thunk_creation.fn b/tests/fn/test_thunk_creation.fn index e0c72857..e3c54624 100644 --- a/tests/fn/test_thunk_creation.fn +++ b/tests/fn/test_thunk_creation.fn @@ -5,16 +5,8 @@ // Zero-argument function should be a thunk fn zero_arg() { 42 } - // One-argument function should be a regular function - fn one_arg(x) { x } in - puts("Zero-arg function type: "); - print(typeof zero_arg); + assert((typeof zero_arg) == "#() -> number"); - puts("One-arg function type: "); - print(typeof one_arg); - - // Test that we can call the thunk - puts("\nCalling zero_arg(): "); - print(zero_arg()); -} \ No newline at end of file + assert(zero_arg() == 42); +} diff --git a/tests/fn/test_thunk_operators.fn b/tests/fn/test_thunk_operators.fn index 99167f07..d553398c 100644 --- a/tests/fn/test_thunk_operators.fn +++ b/tests/fn/test_thunk_operators.fn @@ -17,16 +17,12 @@ let // Force twice value = *(*double_thunk); in - print("Type of x (thunk): " @@ typeof x); - print("Type of y (forced): " @@ typeof y); - print("Value of y: " @@ $y); + assert(typeof x == "#() -> number"); + assert(typeof y == "number"); - print("Type of double_thunk: " @@ typeof double_thunk); - print("Type of double forced double_thunk: " @@ typeof value); - print("Value after double force: " @@ $value); + assert(typeof double_thunk == "#() -> #() -> number"); + assert(typeof value == "number"); assert(y == 3); assert(value == 42); - - print("Thunk operator tests passed!"); - + \ No newline at end of file diff --git a/tests/fn/test_thunk_type.fn b/tests/fn/test_thunk_type.fn deleted file mode 100644 index ab3d9b60..00000000 --- a/tests/fn/test_thunk_type.fn +++ /dev/null @@ -1,13 +0,0 @@ -// Test the new thunk type - -// For now, we'll create a simple function that we can test with -{ -let -fn identity(x) { x } -macro midentity(x) { x } - -in -// Test that basic types still work -print(typeof identity); -print(typeof midentity); -}; \ No newline at end of file diff --git a/tests/fn/test_tuple_assign.fn b/tests/fn/test_tuple_assign.fn new file mode 100644 index 00000000..e9618947 --- /dev/null +++ b/tests/fn/test_tuple_assign.fn @@ -0,0 +1,6 @@ +let + #(a, _) = #(1, 2); + #(_, b) = #(1, 2); +in + assert(a == 1); + assert(b == 2); \ No newline at end of file diff --git a/tests/fn/test_tuples_complete.fn b/tests/fn/test_tuples_complete.fn index ecc5e397..af924fc5 100644 --- a/tests/fn/test_tuples_complete.fn +++ b/tests/fn/test_tuples_complete.fn @@ -363,4 +363,3 @@ in test_tuple_parameter(); test_pattern_function(); - puts("All tuple tests passed!\n") diff --git a/tests/fn/test_type_system_edge_cases.fn b/tests/fn/test_type_system_edge_cases.fn index 9dbf21cd..4094f7d4 100644 --- a/tests/fn/test_type_system_edge_cases.fn +++ b/tests/fn/test_type_system_edge_cases.fn @@ -15,7 +15,6 @@ let assert(int_result == 42); assert(char_result == 'a'); assert(list_result == [1, 2, 3]); - puts("Polymorphic identity test passed\n") } // Test: Polymorphic list operations @@ -33,7 +32,6 @@ let assert(int_list_len == 3); assert(char_list_len == 3); assert(nested_list_len == 3); - puts("Polymorphic lists test passed\n") } // Test: Type inference with arithmetic @@ -46,7 +44,6 @@ let assert(a == 8); assert(b == 20); assert(c == 28); - puts("Type inference arithmetic test passed\n") } // Test: Type inference with conditionals @@ -61,20 +58,19 @@ let in assert(r1 == 5); assert(r2 == 5); - puts("Type inference conditionals test passed\n") } // Test: Polymorphic option type fn test_polymorphic_option() { let - typedef option(#t) { some(#t) | none } + typedef option(#t) { just(#t) | none } fn unwrap_or { - (some(x), _) { x } + (just(x), _) { x } (none, default) { default } } - opt1 = some(42); + opt1 = just(42); opt2 = none; r1 = unwrap_or(opt1, 0); @@ -82,7 +78,6 @@ let in assert(r1 == 42); assert(r2 == 99); - puts("Polymorphic option test passed\n") } // Test: Polymorphic either type @@ -112,24 +107,22 @@ let assert(l2 == 0); assert(r1 == 0); assert(r2 == 20); - puts("Polymorphic either test passed\n") } // Test: Nested polymorphic types fn test_nested_polymorphic() { let - typedef option(#t) { some(#t) | none } + typedef option(#t) { just(#t) | none } fn map_option { (none, _) { none } - (some(x), f) { some(f(x)) } + (just(x), f) { just(f(x)) } } - opt = some(5); + opt = just(5); doubled = map_option(opt, fn(x) { x * 2 }); in - assert(doubled == some(10)); - puts("Nested polymorphic test passed\n") + assert(doubled == just(10)); } // Test: Polymorphic tree type @@ -146,7 +139,6 @@ let size = tree_size(t); in assert(size == 3); - puts("Polymorphic tree test passed\n") } // Test: Type with multiple parameters @@ -168,25 +160,23 @@ let in assert(first == 10); assert(second == 'x'); - puts("Multi-param type test passed\n") } // Test: List of polymorphic types fn test_list_of_options() { let - typedef option(#t) { some(#t) | none } + typedef option(#t) { just(#t) | none } fn count_somes { ([]) { 0 } - (some(_) @ t) { 1 + count_somes(t) } + (just(_) @ t) { 1 + count_somes(t) } (none @ t) { count_somes(t) } } - opts = [some(1), none, some(2), some(3), none]; + opts = [just(1), none, just(2), just(3), none]; count = count_somes(opts); in assert(count == 3); - puts("List of options test passed\n") } // Test: Recursive polymorphic function @@ -202,7 +192,6 @@ let in assert(r1 == [3, 2, 1]); assert(r2 == ['c', 'b', 'a']); - puts("Recursive polymorphic test passed\n") } // Test: Higher-order polymorphic function @@ -220,7 +209,6 @@ let in assert(r1 == 7); assert(r2 == 12); - puts("Higher-order polymorphic test passed\n") } // Test: Polymorphic result type @@ -245,7 +233,6 @@ let assert(not is_ok(r2)); assert(not is_err(r1)); assert(is_err(r2)); - puts("Polymorphic result test passed\n") } // Main test runner @@ -263,7 +250,6 @@ let test_recursive_polymorphic(); test_higher_order_polymorphic(); test_polymorphic_result(); - puts("All type system tests completed successfully!") } in diff --git a/tests/fn/test_typedef_advanced.fn b/tests/fn/test_typedef_advanced.fn index a1378f74..c76abc20 100644 --- a/tests/fn/test_typedef_advanced.fn +++ b/tests/fn/test_typedef_advanced.fn @@ -99,17 +99,17 @@ let fn test_generic_option() { let typedef option(#t) { - some(#t) | + just(#t) | none } in { let - x = some(42); + x = just(42); y = none; in { let get_or_default = fn(opt, def) { switch (opt) { - (some(v)) { v } + (just(v)) { v } (none) { def } } }; @@ -368,4 +368,3 @@ in test_generic_fold(); test_binary_tree_operations(); - puts("All advanced typedef tests passed!\n") diff --git a/tests/fn/test_typedef_named_fields.fn b/tests/fn/test_typedef_named_fields.fn index b664b9b6..ab764556 100644 --- a/tests/fn/test_typedef_named_fields.fn +++ b/tests/fn/test_typedef_named_fields.fn @@ -339,4 +339,3 @@ in test_named_fields_with_bool(); test_named_fields_recursive(); - puts("All named fields tests passed!\n") diff --git a/tests/fn/test_typeof.fn b/tests/fn/test_typeof.fn index 91a961ef..9b0c9ed9 100644 --- a/tests/fn/test_typeof.fn +++ b/tests/fn/test_typeof.fn @@ -5,7 +5,7 @@ let x = 42; f = fn (x) { x + 1 }; lst = [1, 2, 3]; in - print(typeof x); - print(typeof y); - print(typeof f); - print(typeof lst); + assert(typeof x == "number"); + assert(typeof y == "char"); + assert(typeof f == "number -> number"); + assert(typeof lst == "list(number)"); \ No newline at end of file diff --git a/tests/fn/test_typeof_comprehensive.fn b/tests/fn/test_typeof_comprehensive.fn index 2f1088f9..34db4fcf 100644 --- a/tests/fn/test_typeof_comprehensive.fn +++ b/tests/fn/test_typeof_comprehensive.fn @@ -15,12 +15,4 @@ in assert(typeof f == "number -> number"); // Test list types - assert(typeof lst == "list(number)"); - - // Print all types for visual verification - print("Type of 42: " @@ typeof x); - print("Type of 'a': " @@ typeof y); - print("Type of fn(x){x+1}: " @@ typeof f); - print("Type of [1,2,3]: " @@ typeof lst); - print("Type of #(1, \"hello\"): " @@ typeof tup); - print("Type of identity function: " @@ typeof id); + assert(typeof lst == "list(number)"); \ No newline at end of file diff --git a/tests/fn/test_unicode.fn b/tests/fn/test_unicode.fn index 09cc00fd..0aace02e 100644 --- a/tests/fn/test_unicode.fn +++ b/tests/fn/test_unicode.fn @@ -149,4 +149,3 @@ in test_unicode_basic(); test_unicode_ascii(); test_unicode_extended(); - puts("Unicode tests passed\n") diff --git a/tests/fn/bug_maximum_byte_size.fn b/tests/fn/test_unicode_extended.fn similarity index 92% rename from tests/fn/bug_maximum_byte_size.fn rename to tests/fn/test_unicode_extended.fn index b5b3c519..606954cf 100644 --- a/tests/fn/bug_maximum_byte_size.fn +++ b/tests/fn/test_unicode_extended.fn @@ -3,7 +3,6 @@ let Σ = "abc\u03b1;\u03b2;\u03b3;"; Ψ = "abcαβγ"; α = '\u03b1;'; - F♮ = "cool"; alpha = 'α'; α = '\u03b1;'; smile = '😀'; @@ -16,7 +15,6 @@ in assert(chr(945) == α); assert(chr(0x3b1) == α); assert("F\u266e;" == "F♮"); - assert(F♮ == "cool"); assert(unicode_category(alpha) == GC_Ll); assert(ord(smile) == 0x1F600); // isalnum tests @@ -124,6 +122,13 @@ in // Superscripts and subscripts assert(isnumber('²')); // superscript two assert(isnumber('₃')); // subscript three + // Non-Ascii numbers + assert(isnumber('٢')); // Arabic-Indic digit two + assert(isnumber('৪')); // Bengali digit four + // Unicode decimal value retrieval + assert(getdec('５') == 5); // Fullwidth digit five + assert(getdec('९') == 9); // Devanagari digit nine + assert(getdec('٧') == 7); // Arabic-Indic digit seven // Spaces of various widths assert(isspace('\u00a0;')); // non-breaking space assert(isspace('\u3000;')); // ideographic space @@ -133,4 +138,3 @@ in assert(not isprint('\u001b;')); // Combining characters assert(not isalpha('\u0301;')); // combining acute accent (mark, not letter) - puts("Unicode tests passed\n") diff --git a/tests/fn/test_unification.fn b/tests/fn/test_unification.fn index c61dc46a..4238d3fb 100644 --- a/tests/fn/test_unification.fn +++ b/tests/fn/test_unification.fn @@ -1,6 +1,6 @@ // Test: Do lazy and strict functions unify? let -macro lazy_or(a, b) { a or b } +lazy fn lazy_or(a, b) { a or b } fn strict_or(x, y) { x or y } @@ -15,13 +15,8 @@ in y = polymorphic_test(strict_or); in - puts("Both lazy and strict functions type check!\n"); - puts("lazy_or type: "); - print(typeof lazy_or); - puts("strict_or type: "); - print(typeof strict_or); - puts("x (lazy) type: "); - print(typeof x); - puts("y (strict) type:"); - print(typeof y); + assert((typeof lazy_or) == "#() -> bool -> #() -> bool -> bool"); + assert((typeof strict_or) == "bool -> bool -> bool"); + assert((typeof x) == "#() -> bool -> #() -> bool -> bool"); + assert((typeof y) == "bool -> bool -> bool"); } diff --git a/tests/fn/test_unification2.fn b/tests/fn/test_unification2.fn new file mode 100644 index 00000000..cd677be6 --- /dev/null +++ b/tests/fn/test_unification2.fn @@ -0,0 +1,15 @@ +let + typedef term { + num(number) | + mul(term, term) + } + + fn fixed { + (mul(mul(num(1), x), x)) { 1 } + (mul(x, mul(num(1), x))) { 2 } + (x) { 3 } + } +in + assert(fixed(mul(mul(num(1), num(2)), num(2))) == 1); + assert(fixed(mul(num(2), mul(num(1), num(2)))) == 2); + assert(fixed(mul(num(1), num(2))) == 3); \ No newline at end of file diff --git a/tests/fn/test_unification3.fn b/tests/fn/test_unification3.fn new file mode 100644 index 00000000..0e44c9eb --- /dev/null +++ b/tests/fn/test_unification3.fn @@ -0,0 +1,18 @@ +let + typedef term { + num(number) | + add(term, term) | + sub(term, term) + } + + fn broken { + (add(num(0), a)) | + (add(a, num(0))) { 2 } + (add(num(a), sub(num(0), num(a)))) | + (add(sub(num(0), num(a)), num(a))) { 0 } + (_) { 1 } + } +in + assert(broken(add(num(5), sub(num(0), num(5))) ) == 0); + assert(broken(add(sub(num(0), num(5)), num(5)) ) == 0); + assert(broken(num(10)) == 1); \ No newline at end of file diff --git a/tests/fn/test_unification4.fn b/tests/fn/test_unification4.fn new file mode 100644 index 00000000..3980412d --- /dev/null +++ b/tests/fn/test_unification4.fn @@ -0,0 +1,16 @@ +let + +typedef term { + num(number) | + div(term, term) | + var(string) +} + +fn simplify { + (div(num(a), num(b))) { num(a / b) } + (div(x, x)) { num(1) } + (x) { x } +} + +in + assert(simplify(div(num(1), var("x"))) == div(num(1), var("x"))); \ No newline at end of file diff --git a/tests/fn/test_unification5.fn b/tests/fn/test_unification5.fn new file mode 100644 index 00000000..041118e2 --- /dev/null +++ b/tests/fn/test_unification5.fn @@ -0,0 +1,18 @@ +let + +typedef term { + num(number) | + mul(term, term) | + pow(term, term) | + var(string) | + cast(term) +} + +fn simplify { + (mul(num(a), num(b))) { num(a * b) } + (mul(a, a)) { pow(a, num(2)) } + (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/fn/test_unify_alias.fn b/tests/fn/test_unify_alias.fn new file mode 100644 index 00000000..0d070538 --- /dev/null +++ b/tests/fn/test_unify_alias.fn @@ -0,0 +1,85 @@ +let + // Case A: variable first, then assignment (x, x=1) + fn test_case_a { + (x, x=1) { true } + (_, _) { false } + } + + // Case B: assignment first, then variable (x=1, x) + fn test_case_b { + (x=1, x) { true } + (_, _) { false } + } + + // Test with different types + fn test_char { + (x='a', x) { true } + (_, _) { false } + } + + // Test with any list value (no specific pattern constraint) + fn test_list { + (x=l, x) { true } + (_, _) { false } + } + + // Test with cons pattern constraint + fn test_cons { + (x=h@t, x) { true } + (_, _) { false } + } + + // Test Case A with character literals + fn test_case_a_char { + (x, x='b') { true } + (_, _) { false } + } + + // Test Case A with constructor patterns + fn test_case_a_cons { + (x, x=h@t) { true } + (_, _) { false } + } + + // Test mixed patterns: both Case A and Case B in same function + fn test_mixed { + (x=1, x, y, y=2) { true } // Case B, then Case A + (_, _, _, _) { false } + } +in + // Case A tests: variable first, then assignment + assert(test_case_a(1, 1) == true); + assert(test_case_a(1, 2) == false); + assert(test_case_a(2, 1) == false); + + assert(test_case_a_char('b', 'b') == true); + assert(test_case_a_char('a', 'b') == false); + assert(test_case_a_char('b', 'a') == false); + + assert(test_case_a_cons([1, 2], [1, 2]) == true); + assert(test_case_a_cons([1], [1]) == true); + assert(test_case_a_cons([], []) == false); // not a cons + assert(test_case_a_cons([1], [2]) == false); + + // Mixed Case A and Case B + assert(test_mixed(1, 1, 2, 2) == true); + assert(test_mixed(1, 1, 2, 3) == false); + assert(test_mixed(1, 2, 2, 2) == false); + + // Case B tests: assignment first, then variable + assert(test_case_b(1, 1) == true); + assert(test_case_b(1, 2) == false); + assert(test_case_b(2, 1) == false); + + assert(test_char('a', 'a') == true); + assert(test_char('a', 'b') == false); + + // These pass because assignment doesn't constrain the inner pattern + assert(test_list([], []) == true); + assert(test_list([1], [1]) == true); + assert(test_list([1], []) == false); + + // These require both args to be cons cells and equal + assert(test_cons([1, 2], [1, 2]) == true); + assert(test_cons([1], [2]) == false); + assert(test_cons([], []) == false); // [] is not a cons \ No newline at end of file diff --git a/tools/anf_continuations.yaml b/tools/anf_continuations.yaml index 388e4d11..08671808 100644 --- a/tools/anf_continuations.yaml +++ b/tools/anf_continuations.yaml @@ -8,53 +8,16 @@ config: name: anf_kont description: "Continuation scaffolding for ANF normalization" parserInfo: false - currency: LamExp + currency: MinExp includes: - - lambda.h + - minlam.h limited_includes: - - lambda_debug.h + - minlam_debug.h primitives: !include ../src/primitives.yaml external: - LamExp: - meta: - brief: Lambda expressions - data: - cname: "struct LamExp *" - printFn: printLamExp - markFn: markLamExp - valued: true - LamArgs: - meta: - brief: List of LamExp - data: - cname: "struct LamArgs *" - printFn: printLamArgs - markFn: markLamArgs - valued: true - LamBindings: - meta: - brief: List of LamBindings - data: - cname: "struct LamBindings *" - printFn: printLamBindings - markFn: markLamBindings - valued: true - LamCondCases: - meta: - brief: List of LamCondCases - data: - cname: "struct LamCondCases *" - printFn: printLamCondCases - markFn: markLamCondCases - valued: true - LamMatchList: - data: - cname: "struct LamMatchList *" - printFn: printLamMatchList - markFn: markLamMatchList - valued: true +- !include ../src/minlam.yaml continuations: normalizeTerm: @@ -78,21 +41,6 @@ continuations: free_vars: k: AnfKont - normalizeLet: - key: let - brief: "Continuation for let-expression bindings" - context: | - (match e - ... - (`(let ,bindings ,body) - (normalize-bindings bindings - [λ (anfbindings) - `(let ,anfbindings - ,(normalize body k))]))) - free_vars: - body: LamExp - k: AnfKont - normalizeIff: key: iff brief: "Continuation for if-expression test" @@ -107,8 +55,8 @@ continuations: ,(normalize-term e2)))]))) free_vars: k: AnfKont - e1: LamExp - e2: LamExp + e1: MinExp + e2: MinExp normalizeApplyOuter: key: callOuter @@ -122,7 +70,7 @@ continuations: (normalize-names Ms (λ (ts) (k `(,t . ,ts))))])))) free_vars: - Ms: LamArgs + Ms: MinExprList k: AnfKont normalizeApplyInner: @@ -137,7 +85,7 @@ continuations: (normalize-names Ms [λ (ts) (k `(,t . ,ts))]))))) free_vars: - t: LamExp + t: MinExp k: AnfKont normalizeNamesOuter: @@ -151,7 +99,7 @@ continuations: (normalize-names (cdr Ms) (λ (ts) (k `(,t . ,ts))))])))) free_vars: - Ms: LamArgs + Ms: MinExprList k: AnfKont normalizeNamesInner: @@ -165,7 +113,7 @@ continuations: (normalize-names (cdr Ms) [λ (ts) (k `(,t . ,ts))])])))) free_vars: - t: LamExp + t: MinExp k: AnfKont normalizeLetRec: @@ -180,7 +128,7 @@ continuations: `(letrec ,anfbindings ,(normalize body k))]))) free_vars: - body: LamExp + body: MinExp k: AnfKont normalizeBindingsOuter: @@ -199,7 +147,7 @@ continuations: (k `((,x ,anfval) . ,anfrest))))])))) free_vars: x: HashSymbol - rest: LamBindings + rest: MinBindings k: AnfKont normalizeBindingsInner: @@ -218,33 +166,7 @@ continuations: (k `((,x ,anfval) . ,anfrest))]))))) free_vars: x: HashSymbol - anfVal: LamExp - k: AnfKont - - normalizeConstruct: - key: construct - brief: "Continuation for type constructor application" - context: | - (match e - ... - (`(construct ,name ,tag . ,Ms) - (normalize-names Ms - [λ (ts) (k `(construct ,name ,tag . ,ts))]))) - free_vars: - name: HashSymbol - tag: int - k: AnfKont - - normalizeMakeTuple: - key: makeTuple - brief: "Continuation for tuple construction" - context: | - (match e - ... - (`(make-tuple . ,Ms) - (normalize-names Ms - [λ (ts) (k `(make-tuple . ,ts))]))) - free_vars: + anfVal: MinExp k: AnfKont normalizeMakeVec: @@ -257,22 +179,6 @@ continuations: (normalize-names Ms [λ (ts) (k `(make-vec ,nArgs . ,ts))]))) free_vars: - nArgs: int - k: AnfKont - - normalizeDeconstruct: - key: deconstruct - brief: "Continuation for deconstruct operation" - context: | - (match e - ... - (`(deconstruct ,name ,nsId ,vec ,e0) - (normalize-name e0 - [λ (t) (k `(deconstruct ,name ,nsId ,vec ,t))]))) - free_vars: - name: HashSymbol - nsId: int - vec: int k: AnfKont normalizeCond: @@ -286,7 +192,7 @@ continuations: [λ (t) (k `(cond ,t ,(normalize-cases cases)))]))) free_vars: - cases: LamCondCases + cases: MinCondCases k: AnfKont normalizeMatch: @@ -301,7 +207,7 @@ continuations: (k `(match-expr ,t ,(normalize-match-cases cases)))]))) free_vars: - cases: LamMatchList + cases: MinMatchList k: AnfKont normalizePrimappOuter: @@ -318,7 +224,7 @@ continuations: (k `(primitive-apply ,type ,anfE1 ,anfE2))))]))) free_vars: type: int - e2: LamExp + e2: MinExp k: AnfKont normalizePrimappInner: @@ -335,57 +241,7 @@ continuations: (k `(primitive-apply ,type ,anfE1 ,anfE2))]))))) free_vars: type: int - anfE1: LamExp - k: AnfKont - - normalizePrint: - key: print - brief: "Continuation for print expression" - context: | - (match e - ... - (`(print ,e0) - (normalize-name e0 - [λ (anfE0) (k `(print ,anfE0))]))) - free_vars: - k: AnfKont - - normalizeTypeOf: - key: typeOf - brief: "Continuation for typeOf expression" - context: | - (match e - ... - (`(typeOf ,e0) - (normalize-name e0 - [λ (anfE0) (k `(typeOf ,anfE0))]))) - free_vars: - k: AnfKont - - normalizeTupleIndex: - key: tupleIndex - brief: "Continuation for tuple access" - context: | - (match e - ... - (`(tuple-index ,vec ,size ,e0) - (normalize-name e0 - [λ (t0) (k `(tuple-index ,vec ,size ,t0))]))) - free_vars: - vec: int - size: int - k: AnfKont - - normalizeTag: - key: tag - brief: "Continuation for tag extraction" - context: | - (match e - ... - (`(tag ,e0) - (normalize-name e0 - [λ (t0) (k `(tag ,t0))]))) - free_vars: + anfE1: MinExp k: AnfKont normalizeCallCC: diff --git a/tools/cps_continuations.yaml b/tools/cps_continuations.yaml index 0e3b44df..93cbda21 100644 --- a/tools/cps_continuations.yaml +++ b/tools/cps_continuations.yaml @@ -5,70 +5,22 @@ # needs to create a closure to capture the continuation of a computation. # # Note: Only T_k transformations need continuation scaffolding. -# T_c transformations pass LamExp* as regular function parameters. +# T_c transformations pass MinExp* as regular function parameters. config: name: cps_kont description: "Continuation scaffolding for CPS transform" parserInfo: false - currency: LamExp + currency: MinExp includes: - - lambda.h + - minlam.h limited_includes: - - lambda_debug.h + - minlam_debug.h primitives: !include ../src/primitives.yaml external: - LamExp: - meta: - brief: Lambda expressions - data: - cname: "struct LamExp *" - printFn: printLamExp - markFn: markLamExp - valued: true - LamArgs: - meta: - brief: List of LamExp - data: - cname: "struct LamArgs *" - printFn: printLamArgs - markFn: markLamArgs - valued: true - LamBindings: - meta: - brief: List of LamBindings - data: - cname: "struct LamBindings *" - printFn: printLamBindings - markFn: markLamBindings - valued: true - LamCondCases: - meta: - brief: List of LamCondCases - data: - cname: "struct LamCondCases *" - printFn: printLamCondCases - markFn: markLamCondCases - valued: true - LamMatchList: - data: - cname: "struct LamMatchList *" - printFn: printLamMatchList - markFn: markLamMatchList - valued: true - LamPrimOp: - data: - cname: "enum LamPrimOp" - printf: "%d" - valued: true - LamSequence: - data: - cname: "struct LamSequence *" - printFn: printLamSequence - markFn: markLamSequence - valued: true +- !include ../src/minlam.yaml # Naming convention, since each kont is argument to T_k and never # to T_c, we use Tk for continuations constructed by T_k, and @@ -95,9 +47,9 @@ continuations: } } free_vars: - c: LamExp - exprt: LamExp - exprf: LamExp + c: MinExp + exprt: MinExp + exprf: MinExp TcIff: transformer: T_k @@ -117,9 +69,9 @@ continuations: } } free_vars: - sk: LamExp - exprt: LamExp - exprf: LamExp + sk: MinExp + exprt: MinExp + exprf: MinExp TcApply1: transformer: T_k @@ -136,8 +88,8 @@ continuations: } } free_vars: - es: LamArgs - c: LamExp + es: MinExprList + c: MinExp TcApply2: transformer: T_k @@ -154,8 +106,8 @@ continuations: } } free_vars: - sf: LamExp - c: LamExp + sf: MinExp + c: MinExp TkCond: transformer: T_k @@ -177,8 +129,8 @@ continuations: } } free_vars: - c: LamExp - branches: LamCondCases + c: MinExp + branches: MinCondCases TcCond: transformer: T_k @@ -200,8 +152,8 @@ continuations: } } free_vars: - sk: LamExp - branches: LamCondCases + sk: MinExp + branches: MinCondCases TkS1: transformer: T_k @@ -218,7 +170,7 @@ continuations: } } free_vars: - t: LamArgs + t: MinExprList k: CpsKont TkS2: @@ -237,7 +189,7 @@ continuations: } free_vars: k: CpsKont - hd: LamExp + hd: MinExp TcCallCC: transformer: T_k @@ -252,89 +204,7 @@ continuations: }) } free_vars: - c: LamExp - - TkConstruct: - transformer: T_k - key: k_construct - context: | - (E.construct(name, tag, args)) { - Ts_k(args, fn (sargs) { - k(E.construct(name, tag, sargs)) - }) - } - free_vars: - name: HashSymbol - tag: int - k: CpsKont - - TcConstruct: - transformer: T_k - key: c_construct - context: | - (E.construct(name, tag, args)) { - Ts_k(args, fn (sargs) { - E.apply(c, [E.construct(name, tag, sargs)]) - }) - } - free_vars: - name: HashSymbol - tag: int - c: LamExp - - TkDeconstruct: - transformer: T_k - key: k_deconstruct - context: | - (E.deconstruct(name, nsId, vec, expr)) { - T_k(expr, fn (sexpr) { - k(E.deconstruct(name, nsId, vec, sexpr)) - }) - } - free_vars: - name: HashSymbol - nsId: int - vec: int - k: CpsKont - - TcDeconstruct: - transformer: T_k - key: c_deconstruct - context: | - (E.deconstruct(name, nsId, vec, expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.deconstruct(name, nsId, vec, sexpr)]) - }) - } - free_vars: - name: HashSymbol - nsId: int - vec: int - c: LamExp - - TkMakeTuple: - transformer: T_k - key: k_maketuple - context: | - (E.make_tuple(args)) { - Ts_k(args, fn (sargs) { - k(E.make_tuple(sargs)) - }) - } - free_vars: - k: CpsKont - - TcMakeTuple: - transformer: T_k - key: c_maketuple - context: | - (E.make_tuple(args)) { - Ts_k(args, fn (sargs) { - E.apply(c, [E.make_tuple(sargs)]) - }) - } - free_vars: - c: LamExp + c: MinExp TkMakeVec: transformer: T_k @@ -346,7 +216,6 @@ continuations: }) } free_vars: - size: int k: CpsKont TcMakeVec: @@ -359,8 +228,7 @@ continuations: }) } free_vars: - size: int - c: LamExp + c: MinExp TkMatch: transformer: T_k @@ -377,8 +245,8 @@ continuations: }) } free_vars: - c: LamExp - cases: LamMatchList + c: MinExp + cases: MinMatchList TcMatch: transformer: T_k @@ -395,8 +263,8 @@ continuations: })), [c]) } free_vars: - sk: LamExp - cases: LamMatchList + sk: MinExp + cases: MinMatchList TkNameSpaces: transformer: T_k @@ -420,7 +288,7 @@ continuations: }) } free_vars: - c: LamExp + c: MinExp TkPrimApp1: transformer: T_k @@ -435,8 +303,8 @@ continuations: } free_vars: k: CpsKont - e2: LamExp - p: LamPrimOp + e2: MinExp + p: MinPrimOp TkPrimApp2: transformer: T_k @@ -451,8 +319,8 @@ continuations: } free_vars: k: CpsKont - s1: LamExp - p: LamPrimOp + s1: MinExp + p: MinPrimOp TcPrimApp1: transformer: T_k @@ -466,9 +334,9 @@ continuations: }) /////////////////////////////////////////// } free_vars: - c: LamExp - e2: LamExp - p: LamPrimOp + c: MinExp + e2: MinExp + p: MinPrimOp TcPrimApp2: transformer: T_k @@ -482,33 +350,9 @@ continuations: }) } free_vars: - c: LamExp - s1: LamExp - p: LamPrimOp - - TkPrint: - transformer: T_k - key: k_print - context: | - (E.print_exp(expr)) { - T_k(expr, fn (sexpr) { - k(E.print_exp(sexpr)) - }) - } - free_vars: - k: CpsKont - - TcPrint: - transformer: T_k - key: c_print - context: | - (E.print_exp(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.print_exp(sexpr)]) - }) - } - free_vars: - c: LamExp + c: MinExp + s1: MinExp + p: MinPrimOp TkSequence: transformer: T_k @@ -522,7 +366,7 @@ continuations: } free_vars: k: CpsKont - exprs: LamSequence + exprs: MinExprList TcSequence: transformer: T_k @@ -535,81 +379,5 @@ continuations: }) } free_vars: - c: LamExp - exprs: LamSequence - - TkTag: - transformer: T_k - key: k_tag - context: | - (E.tag(expr)) { - T_k(expr, fn (sexpr) { - k(E.tag(sexpr)) - }) - } - free_vars: - k: CpsKont - - TcTag: - transformer: T_k - key: c_tag - context: | - (E.tag(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.tag(sexpr)]) - }) - } - free_vars: - c: LamExp - - TkTupleIndex: - transformer: T_k - key: k_tupleindex - context: | - (E.tuple_index(size, index, expr)) { - T_k(expr, fn (sexpr) { - k(E.tuple_index(size, index, sexpr)) - }) - } - free_vars: - size: int - index: int - k: CpsKont - - TcTupleIndex: - transformer: T_k - key: c_tupleindex - context: | - (E.tuple_index(size, index, expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.tuple_index(size, index, sexpr)]) - }) - } - free_vars: - size: int - index: int - c: LamExp - - TkTypeOf: - transformer: T_k - key: k_typeOf - context: | - (E.typeOf_expr(expr)) { - T_k(expr, fn (sexpr) { - k(E.typeOf_expr(sexpr)) - }) - } - free_vars: - k: CpsKont - - TcTypeOf: - transformer: T_k - key: c_typeOf - context: | - (E.typeOf_expr(expr)) { - T_k(expr, fn (sexpr) { - E.apply(c, [E.typeOf_expr(sexpr)]) - }) - } - free_vars: - c: LamExp \ No newline at end of file + c: MinExp + exprs: MinExprList diff --git a/tools/find_new_union_pattern.py b/tools/find_new_union_pattern.py new file mode 100755 index 00000000..829b017a --- /dev/null +++ b/tools/find_new_union_pattern.py @@ -0,0 +1,117 @@ +#!/usr/bin/env python3 +""" +Find pattern: newType() followed by PROTECT then newUnion_Type(name) + +This script searches for code patterns where a type is allocated, protected, +then wrapped in a union. These can potentially be simplified using make*() +functions. + +Usage: + python3 tools/find_new_union_pattern.py src/*.c + python3 tools/find_new_union_pattern.py src/pratt_parser.c +""" + +import re +import sys +from pathlib import Path + + +def find_pattern_in_file(filepath): + """ + Find instances of the pattern: + Type *name = newType(...); + ...PROTECT... + Union *name2 = newUnion_Type(name); + + Returns list of (line_number, context_lines) tuples. + """ + with open(filepath, 'r', encoding='utf-8', errors='ignore') as f: + lines = f.readlines() + + matches = [] + + # Pattern for: Type *name = newType(...); + # Flexible about whitespace, captures Type and name + # Less restrictive - just looks for the assignment pattern + new_pattern = re.compile( + r'^\s*([A-Z][a-zA-Z0-9]*)\s*\*\s*([a-zA-Z_][a-zA-Z0-9_]*)\s*=\s*new\1\s*\(', + re.IGNORECASE + ) + + # Pattern for: Union *name2 = newUnion_Type(...); + # Captures Union, Type, and looks for the original variable name anywhere on the line + # Very permissive to handle complex argument lists like CPI(node), other, var) + union_pattern = re.compile( + r'^\s*([A-Z][a-zA-Z0-9]*)\s*\*\s*([a-zA-Z_][a-zA-Z0-9_]*)\s*=\s*' + r'new\1_([A-Z][a-zA-Z0-9]*)\s*\(', + re.IGNORECASE + ) + + i = 0 + while i < len(lines): + match = new_pattern.match(lines[i]) + if match: + type_name = match.group(1) + var_name = match.group(2) + start_line = i + + # Look ahead for PROTECT and then newUnion_Type + # Search within the next 4 lines (reasonable window) + found_protect = False + for j in range(i + 1, min(i + 5, len(lines))): + if 'PROTECT' in lines[j]: + found_protect = True + + union_match = union_pattern.match(lines[j]) + if union_match and found_protect: + union_type = union_match.group(1) + union_var = union_match.group(2) + variant_type = union_match.group(3) + + # Check if the original variable name appears in this line + # (handles cases like newUnion_Type(CPI(x), otherargs, var)) + # Don't check type matching - just look for the variable name + if re.search(r'\b' + re.escape(var_name) + r'\b', lines[j]): + # Found a match! + context = { + 'start_line': start_line + 1, # 1-indexed + 'end_line': j + 1, + 'type_name': type_name, + 'var_name': var_name, + 'union_type': union_type, + 'union_var': union_var, + 'context_lines': lines[start_line:j+1] + } + matches.append(context) + break + i += 1 + + return matches + + +def format_match(filepath, match): + """Format a match for display.""" + output = [] + output.append(f"{filepath}:") + for i, line in enumerate(match['context_lines'], start=match['start_line']): + output.append(f"{i}: {line.rstrip()}") + return '\n'.join(output) + + +def main(): + if len(sys.argv) < 2: + print(__doc__) + sys.exit(1) + + for pattern in sys.argv[1:]: + for filepath in Path('.').glob(pattern): + if filepath.is_file() and filepath.suffix in ['.c', '.h']: + matches = find_pattern_in_file(filepath) + + if matches: + for match in matches: + print(format_match(filepath, match)) + + +if __name__ == '__main__': + main() diff --git a/tools/generate.py b/tools/generate.py old mode 100644 new mode 100755 index e6f80d47..a562e96e --- a/tools/generate.py +++ b/tools/generate.py @@ -65,75 +65,96 @@ def main(): stream = open(args.yaml, 'r') document = yaml.load(stream, Loader) - typeName = document['config']['name'] + packageName = document['config']['name'] description = document['config']['description'] includes = document['config'].get('includes', []) limited_includes = document['config'].get('limited_includes', []) - parserInfo = document['config'].get('parserInfo', False) + catalog = Catalog() + process_document(document, catalog, False) + catalog.build() + generate_output(args, catalog, document, packageName, description, includes, limited_includes) + - catalog = Catalog(typeName) +def process_document(document, catalog, external): + """Process the YAML document and build the catalog""" - if parserInfo: - catalog.noteParserInfo() + locals = {} # Build catalog from YAML document if "hashes" in document: for name in document["hashes"]: - catalog.add(SimpleHash(name, document["hashes"][name])) + catalog.add(SimpleHash(name, document["hashes"][name]), external) + locals[name] = catalog.get(name) if "structs" in document: for name in document["structs"]: - catalog.add(SimpleStruct(name, document["structs"][name])) + catalog.add(SimpleStruct(name, document["structs"][name]), external) + locals[name] = catalog.get(name) if "vectors" in document: for name in document["vectors"]: - catalog.add(SimpleVector(name, document["vectors"][name])) + catalog.add(SimpleVector(name, document["vectors"][name]), external) + locals[name] = catalog.get(name) if "inline" in document: if "structs" in document["inline"]: for name in document["inline"]["structs"]: - catalog.add(InlineStruct(name, document["inline"]["structs"][name])) + catalog.add(InlineStruct(name, document["inline"]["structs"][name]), external) + locals[name] = catalog.get(name) if "unions" in document["inline"]: for name in document["inline"]["unions"]: - catalog.add(InlineDiscriminatedUnion(name, document["inline"]["unions"][name])) + catalog.add(InlineDiscriminatedUnion(name, document["inline"]["unions"][name]), external) + locals[name] = catalog.get(name) if "arrays" in document["inline"]: for name in document["inline"]["arrays"]: - catalog.add(InlineArray(name, document["inline"]["arrays"][name])) + catalog.add(InlineArray(name, document["inline"]["arrays"][name]), external) + locals[name] = catalog.get(name) if "unions" in document: for name in document["unions"]: - catalog.add(DiscriminatedUnion(name, document["unions"][name])) + catalog.add(DiscriminatedUnion(name, document["unions"][name]), external) + locals[name] = catalog.get(name) if "stacks" in document: for name in document["stacks"]: - catalog.add(SimpleStack(name, document["stacks"][name])) + catalog.add(SimpleStack(name, document["stacks"][name]), external) + locals[name] = catalog.get(name) if "enums" in document: for name in document["enums"]: - catalog.add(SimpleEnum(name, document["enums"][name])) + catalog.add(SimpleEnum(name, document["enums"][name]), external) + locals[name] = catalog.get(name) if "primitives" in document: for name in document["primitives"]: - catalog.add(Primitive(name, document["primitives"][name])) + catalog.add(Primitive(name, document["primitives"][name]), external) + locals[name] = catalog.get(name) if "external" in document: - for name in document["external"]: - catalog.add(Primitive(name, document["external"][name])) + for externalDoc in document["external"]: + process_document(externalDoc, catalog, True) if "arrays" in document: for name in document["arrays"]: - catalog.add(SimpleArray(name, document["arrays"][name])) + catalog.add(SimpleArray(name, document["arrays"][name]), external) + locals[name] = catalog.get(name) + + if "config" in document: + parserInfo = document['config'].get('parserInfo', False) + for local in locals: + locals[local].setParserInfo(parserInfo) if "tags" in document: for tag in document["tags"]: - catalog.tag(tag) + locals[tag].tag() if "cmp" in document: if "extraArgs" in document["cmp"]: - catalog.noteExtraCmpArgs(document["cmp"]["extraArgs"]) + for local in locals: + locals[local].noteExtraEqArgs(document["cmp"]["extraArgs"]) if "bespokeImplementation" in document["cmp"]: for bespoke in document["cmp"]["bespokeImplementation"]: - catalog.noteBespokeCmpImplementation(bespoke) + locals[bespoke].noteBespokeEqImplementation() # For continuation YAML, add generated structs/unions to catalog if "continuations" in document: @@ -141,34 +162,29 @@ def main(): generator = KontinuationGenerator(document) generator.populate_catalog(catalog) - catalog.build() - - # Generate output based on type - generate_output(args, catalog, document, typeName, description, includes, limited_includes, parserInfo) - -def generate_output(args, catalog, document, typeName, description, includes, limited_includes, parserInfo): +def generate_output(args, catalog, document, packageName, description, includes, limited_includes): """Generate the appropriate output based on args.type""" if args.type == "h": - generate_header(args, catalog, document, typeName, includes, limited_includes, parserInfo) + generate_header(args, catalog, document, packageName, includes, limited_includes) elif args.type == "objtypes_h": - generate_objtypes_header(args, catalog, document, typeName) + generate_objtypes_header(args, catalog, document, packageName) elif args.type == "c": - generate_implementation(args, catalog, document, typeName) + generate_implementation(args, catalog, document, packageName) elif args.type == 'debug_h': - generate_debug_header(args, catalog, document, typeName, includes, limited_includes) + generate_debug_header(args, catalog, document, packageName, includes, limited_includes) elif args.type == 'debug_c': - generate_debug_implementation(args, catalog, document, typeName, limited_includes) + generate_debug_implementation(args, catalog, document, packageName, limited_includes) elif args.type == 'md': - generate_documentation(args, catalog, typeName, description) + generate_documentation(args, catalog, packageName, description) elif args.type == 'visitor': if args.target == "": print(f"Error: visitor type requires a target argument", file=sys.stderr) sys.exit(1) printGpl(args.yaml, document) print("") - print(catalog.generateVisitor(args.target)) + print(catalog.generateVisitor(packageName, args.target)) elif args.type == 'kont_impl_inc': # For continuation scaffolding, generate .inc (catalog already populated) from generate.kontinuations import KontinuationGenerator @@ -186,18 +202,17 @@ def generate_output(args, catalog, document, typeName, description, includes, li generator.generate_kont_impl_c(sys.stdout, catalog, includes) -def generate_header(args, catalog, document, typeName, includes, limited_includes, parserInfo): +def generate_header(args, catalog, document, packageName, includes, limited_includes): """Generate main header file""" - print(f"#ifndef cekf_{typeName}_h") - print(f"#define cekf_{typeName}_h") + print(f"#ifndef cekf_{packageName}_h") + print(f"#define cekf_{packageName}_h") printGpl(args.yaml, document) print("") print('#include "hash.h"') print('#include "memory.h"') print('#include "common.h"') print('#include "types.h"') - if parserInfo: - print('#include "parser_info.h"') + print('#include "parser_info.h"') for include in includes: print(f'#include "{include}"') for include in limited_includes: @@ -231,6 +246,8 @@ def generate_header(args, catalog, document, typeName, includes, limited_include catalog.printPeeknDeclarations() catalog.printPokeDeclarations() catalog.printExtendDeclarations() + catalog.printAddDeclarations() + catalog.printAppendDeclarations() catalog.printSizeDeclarations() printSection("hash getter and setter declarations") catalog.printGetDeclarations() @@ -250,36 +267,38 @@ def generate_header(args, catalog, document, typeName, includes, limited_include catalog.printGetterDeclarations() printSection("discriminated union setter declarations") catalog.printSetterDeclarations() + printSection("eq declarations") + catalog.printEqDeclarations() print("") print("#endif") -def generate_objtypes_header(args, catalog, document, typeName): +def generate_objtypes_header(args, catalog, document, packageName): """Generate object types header file""" - print(f"#ifndef cekf_{typeName}_objtypes_h") - print(f"#define cekf_{typeName}_objtypes_h") + print(f"#ifndef cekf_{packageName}_objtypes_h") + print(f"#define cekf_{packageName}_objtypes_h") printGpl(args.yaml, document) printSection("define objtypes") - catalog.printObjTypeDefine() + catalog.printObjTypeDefine(packageName) printSection("define cases") - catalog.printObjCasesDefine() + catalog.printObjCasesDefine(packageName) printSection("declare generic type functions") - print(f'void mark{typeName.capitalize()}Obj(struct Header *h);') - print(f'void free{typeName.capitalize()}Obj(struct Header *h);') - print(f'char *typename{typeName.capitalize()}Obj(int type);') + print(f'void mark{packageName.capitalize()}Obj(struct Header *h);') + print(f'void free{packageName.capitalize()}Obj(struct Header *h);') + print(f'char *typename{packageName.capitalize()}Obj(int type);') print("") print("#endif") -def generate_implementation(args, catalog, document, typeName): +def generate_implementation(args, catalog, document, packageName): """Generate main implementation file""" printGpl(args.yaml, document) print("") - print(f'#include "{typeName}.h"') + print(f'#include "{packageName}.h"') print("#include ") print("#include ") print('#include "common.h"') - print(f'#ifdef DEBUG_{typeName.upper()}') + print(f'#ifdef DEBUG_{packageName.upper()}') print('#include "debugging_on.h"') print('#else') print('#include "debugging_off.h"') @@ -304,6 +323,8 @@ def generate_implementation(args, catalog, document, typeName): catalog.printPeeknFunctions() catalog.printPokeFunctions() catalog.printExtendFunctions() + catalog.printAddFunctions() + catalog.printAppendFunctions() printSection("hash getter and setter functions") catalog.printGetFunctions() catalog.printSetFunctions() @@ -313,58 +334,56 @@ def generate_implementation(args, catalog, document, typeName): printSection("mark functions") catalog.printMarkFunctions() printSection("generic mark function") - catalog.printMarkObjFunction() + catalog.printMarkObjFunction(packageName) printSection("free functions") catalog.printFreeFunctions() printSection("generic free function") - catalog.printFreeObjFunction() + catalog.printFreeObjFunction(packageName) printSection("type identifier function") - catalog.printTypeObjFunction() + catalog.printTypeObjFunction(packageName) printSection("type name function") catalog.printNameFunctionBodies() printSection("protect functions") catalog.printProtectFunctions() + printSection("eq functions") + catalog.printEqFunctions() -def generate_debug_header(args, catalog, document, typeName, includes, limited_includes): +def generate_debug_header(args, catalog, document, packageName, includes, limited_includes): """Generate debug header file""" - print(f"#ifndef cekf_{typeName}_debug_h") - print(f"#define cekf_{typeName}_debug_h") + print(f"#ifndef cekf_{packageName}_debug_h") + print(f"#define cekf_{packageName}_debug_h") printGpl(args.yaml, document) print("") - print(f'#include "{typeName}_helper.h"') + print(f'#include "{packageName}_helper.h"') for include in includes: print(f'#include "{include[0:-2]}_debug.h"') for include in limited_includes: print(f'#include "{include}"') printSection("print declarations") catalog.printPrintDeclarations() - printSection("compare declarations") - catalog.printCompareDeclarations() print("") print("#endif") -def generate_debug_implementation(args, catalog, document, typeName, limited_includes): +def generate_debug_implementation(args, catalog, document, packageName, limited_includes): """Generate debug implementation file""" printGpl(args.yaml, document) print("") print('#include ') print("") - print(f'#include "{typeName}_debug.h"') + print(f'#include "{packageName}_debug.h"') for include in limited_includes: print(f'#include "{include}"') printSection("helper functions") print('static void pad(int depth) { eprintf("%*s", depth * PAD_WIDTH, ""); }') printSection("print functions") catalog.printPrintFunctions() - printSection("compare functions") - catalog.printCompareFunctions() -def generate_documentation(args, catalog, typeName, description): +def generate_documentation(args, catalog, packageName, description): """Generate Mermaid documentation""" - print(f"# {typeName}") + print(f"# {packageName}") print("") print(description) print("") diff --git a/tools/generate/base.py b/tools/generate/base.py index 692f19b9..5883aa32 100644 --- a/tools/generate/base.py +++ b/tools/generate/base.py @@ -33,23 +33,25 @@ class Base: def __init__(self, name, body): self.name = name self.tagged = False - self.bespokeCmpImplementation = False - self.extraCmpArgs = {} + self.bespokeEqImplementation = False + self.extraEqArgs = {} self.hasDocs = False self.brief = None self.description = None - if "parserInfo" in body: - self.parserInfo = body["parserInfo"] - else: - self.parserInfo = None + self.parserInfo = None + self.eqIgnore = [] # List of field names to ignore in equality comparison if "meta" in body: meta = body["meta"] + if "parserInfo" in meta: + self.parserInfo = meta["parserInfo"] if "brief" in meta: self.hasDocs = True self.brief = meta["brief"] if "description" in meta: self.hasDocs = True self.description = meta["description"] + if "eqIgnore" in meta: + self.eqIgnore = meta["eqIgnore"] def printBaseDocumentation(self): if self.hasDocs: @@ -62,10 +64,20 @@ def printBaseDocumentation(self): print(f" * {line}") print(" */") - def getParserInfo(self, default): - if self.parserInfo is not None: - return self.parserInfo - return default + def getParserInfo(self): + if self.parserInfo is None: + return False + return self.parserInfo + + def setParserInfo(self, info): + if self.parserInfo is None: + self.parserInfo = info + + def setExternal(self, external): + self.external = external + + def isExternal(self): + return getattr(self, 'external', False) def formatDescription(self): """ @@ -113,8 +125,8 @@ def noteTypedef(self): def isSelfInitializing(self): return False - def noteExtraCmpArgs(self, args): - self.extraCmpArgs = args + def noteExtraEqArgs(self, args): + self.extraEqArgs = args def objTypeArray(self): return [] @@ -127,7 +139,7 @@ def getName(self): def comment(self, method): """Generate method comment using class name automatically.""" - return CommentGen.method_comment(self.__class__.__name__, method) + return CommentGen.method_comment_with_impl(self, method) def hasParserInfo(self, catalog): return False @@ -192,13 +204,13 @@ def printCopyFunction(self, catalog): def printPrintDeclaration(self, catalog): pass - def printCompareDeclaration(self, catalog): + def printEqDeclaration(self, catalog): pass def printPrintFunction(self, catalog): pass - def printCompareFunction(self, catalog): + def printEqFunction(self, catalog): pass def printMarkObjCase(self, catalog): @@ -258,6 +270,12 @@ def printPokeDeclaration(self, catalog): def printExtendDeclaration(self, catalog): pass + def printAppendDeclaration(self, catalog): + pass + + def printAddDeclaration(self, catalog): + pass + def printSizeDeclaration(self, catalog): pass @@ -291,6 +309,12 @@ def printPeeknFunction(self, catalog): def printPokeFunction(self, catalog): pass + def printAppendFunction(self, catalog): + pass + + def printAddFunction(self, catalog): + pass + def printExtendFunction(self, catalog): pass @@ -315,8 +339,8 @@ def isHash(self): def isVector(self): return False - def noteBespokeCmpImplementation(self): - self.bespokeCmpImplementation = True + def noteBespokeEqImplementation(self): + self.bespokeEqImplementation = True def makeCopyCommand(self, arg, catalog): return arg diff --git a/tools/generate/catalog.py b/tools/generate/catalog.py index c798241e..cf0756be 100644 --- a/tools/generate/catalog.py +++ b/tools/generate/catalog.py @@ -30,34 +30,16 @@ class Catalog: """Central registry managing all entities in a schema.""" - def __init__(self, typeName): - self.typeName = typeName + def __init__(self): self.contents = {} - self.parserInfo = False - def add(self, value): + def add(self, value, external): + value.setExternal(external) name = value.getName() if name in self.contents: - raise Exception("attempt to overwtite " + name + " in catalog") + raise Exception("attempt to overwrite " + name + " in catalog") self.contents[name] = value - def tag(self, t): - if t in self.contents: - self.contents[t].tag() - - def noteExtraCmpArgs(self, args): - for key in self.contents: - self.contents[key].noteExtraCmpArgs(args) - - def noteParserInfo(self): - self.parserInfo = True - - def noteBespokeCmpImplementation(self, name): - if name in self.contents: - self.contents[name].noteBespokeCmpImplementation() - else: - raise Exception("bespoke cmp implementation declared for nonexistant entry " + name) - def get(self, key): key = key.strip() if key in self.contents: @@ -73,9 +55,9 @@ def build(self): def getParserInfo(self, key): key = key.strip() if key in self.contents: - return self.contents[key].getParserInfo(self.parserInfo) + return self.contents[key].getParserInfo() else: - return self.parserInfo + raise Exception("key '" + key + "' not found in catalog") def _dispatch(self, method_name, *args): """ @@ -86,8 +68,9 @@ def _dispatch(self, method_name, *args): *args: Arguments to pass to the method (usually self for catalog) """ for entity in self.contents.values(): - method = getattr(entity, method_name) - method(*args) + if not entity.isExternal(): + method = getattr(entity, method_name) + method(*args) def printHelperNewDeclarations(self): self._dispatch('printHelperNewDeclarations', self) @@ -98,17 +81,17 @@ def printGetterDeclarations(self): def printSetterDeclarations(self): self._dispatch('printSetterDeclarations', self) - def generateVisitor(self, target): + def generateVisitor(self, packageName, target): """Generate complete visitor boilerplate""" output = [] # Includes - output.append(f'#include "{self.typeName}.h"\n') + output.append(f'#include "{packageName}.h"\n') output.append('#include "memory.h"\n\n') - output.append(f'#include "{self.typeName}_{target}.h"\n\n') + output.append(f'#include "{packageName}_{target}.h"\n\n') # Conditional debugging include - debug_macro = f"DEBUG_{self.typeName.upper()}_{target.upper()}" + debug_macro = f"DEBUG_{packageName.upper()}_{target.upper()}" output.append(f'#ifdef {debug_macro}\n') output.append('# include "debugging_on.h"\n') output.append('#else\n') @@ -139,27 +122,27 @@ def generateVisitor(self, target): def printTypedefs(self): for entity in self.contents.values(): - if entity.isEnum(): + if entity.isEnum() and not entity.isExternal(): entity.printTypedef(self) for entity in self.contents.values(): - if entity.isArray(): + if entity.isArray() and not entity.isExternal(): entity.printTypedef(self) for entity in self.contents.values(): - if entity.isUnion(): + if entity.isUnion() and not entity.isExternal(): entity.printTypedef(self) # Print inline structs first (no dependencies, can be used by other structs) for entity in self.contents.values(): - if entity.isStruct() and entity.isInline(self): + if entity.isStruct() and entity.isInline(self) and not entity.isExternal(): entity.printTypedef(self) # Then print regular structs for entity in self.contents.values(): - if entity.isStruct() and not entity.isInline(self): + if entity.isStruct() and not entity.isInline(self) and not entity.isExternal(): entity.printTypedef(self) for entity in self.contents.values(): - if entity.isHash(): + if entity.isHash() and not entity.isExternal(): entity.printTypedef(self) for entity in self.contents.values(): - if entity.isVector(): + if entity.isVector() and not entity.isExternal(): entity.printTypedef(self) def printInitDeclarations(self): @@ -219,6 +202,12 @@ def printPeeknDeclarations(self): def printPokeDeclarations(self): self._dispatch('printPokeDeclaration', self) + def printAppendDeclarations(self): + self._dispatch('printAppendDeclaration', self) + + def printAddDeclarations(self): + self._dispatch('printAddDeclaration', self) + def printExtendDeclarations(self): self._dispatch('printExtendDeclaration', self) @@ -255,6 +244,12 @@ def printPeeknFunctions(self): def printPokeFunctions(self): self._dispatch('printPokeFunction', self) + def printAppendFunctions(self): + self._dispatch('printAppendFunction', self) + + def printAddFunctions(self): + self._dispatch('printAddFunction', self) + def printExtendFunctions(self): self._dispatch('printExtendFunction', self) @@ -300,14 +295,14 @@ def printNameFunctionBodies(self): def printPrintFunctions(self): self._dispatch('printPrintFunction', self) - def printCompareFunctions(self): - self._dispatch('printCompareFunction', self) + def printEqFunctions(self): + self._dispatch('printEqFunction', self) def printPrintDeclarations(self): self._dispatch('printPrintDeclaration', self) - def printCompareDeclarations(self): - self._dispatch('printCompareDeclaration', self) + def printEqDeclarations(self): + self._dispatch('printEqDeclaration', self) def printDefines(self): self._dispatch('printDefines', self) @@ -327,38 +322,40 @@ def printFreeFunctions(self): def printMermaid(self): self._dispatch('printMermaid', self) - def printMarkObjFunction(self): + def printMarkObjFunction(self, packageName): SwitchHelper.print_switch_function( - self, 'printMarkObjFunction', 'mark{Type}Obj', 'struct Header *h', + self, packageName, 'printMarkObjFunction', 'mark{Type}Obj', 'struct Header *h', 'printMarkObjCase', - f'cant_happen("unrecognised type %d in mark{self.typeName.capitalize()}Obj\\n", h->type);' + f'cant_happen("unrecognised type %d in mark{packageName.capitalize()}Obj\\n", h->type);' ) - def printFreeObjFunction(self): + def printFreeObjFunction(self, packageName): SwitchHelper.print_switch_function( - self, 'printFreeObjFunction', 'free{Type}Obj', 'struct Header *h', + self, packageName, 'printFreeObjFunction', 'free{Type}Obj', 'struct Header *h', 'printFreeObjCase', - f'cant_happen("unrecognised type %d in free{self.typeName.capitalize()}Obj\\n", h->type);' + f'cant_happen("unrecognised type %d in free{packageName.capitalize()}Obj\\n", h->type);' ) - def printTypeObjFunction(self): + def printTypeObjFunction(self, packageName): SwitchHelper.print_switch_function( - self, 'printTypeObjFunction', 'typename{Type}Obj', 'int type', + self, packageName, 'printTypeObjFunction', 'typename{Type}Obj', 'int type', 'printTypeObjCase', 'return "???"; // no error, can be used during error reporting', 'char *' ) - def printObjTypeDefine(self): + def printObjTypeDefine(self, packageName): objTypeArray = [] for entity in self.contents.values(): - objTypeArray += entity.objTypeArray() - print("#define {typeName}_OBJTYPES() \\\n{a}".format(a=', \\\n'.join(objTypeArray), typeName=self.typeName.upper())) + if not entity.isExternal(): + objTypeArray += entity.objTypeArray() + print("#define {packageName}_OBJTYPES() \\\n{a}".format(a=', \\\n'.join(objTypeArray), packageName=packageName.upper())) - def printObjCasesDefine(self): - print(f"#define {self.typeName.upper()}_OBJTYPE_CASES() \\") + def printObjCasesDefine(self, packageName): + print(f"#define {packageName.upper()}_OBJTYPE_CASES() \\") for entity in self.contents.values(): - objType = entity.objTypeArray() - if len(objType) == 1: - print(f'case {objType[0]}:\\') + if not entity.isExternal(): + objType = entity.objTypeArray() + if len(objType) == 1: + print(f'case {objType[0]}:\\') print("") diff --git a/tools/generate/comment_gen.py b/tools/generate/comment_gen.py index 5f7f5d05..c4f7bf80 100644 --- a/tools/generate/comment_gen.py +++ b/tools/generate/comment_gen.py @@ -24,6 +24,8 @@ refactoring to reduce duplication. """ +import inspect + class CommentGen: """Generate C-style comments and documentation""" @@ -44,3 +46,35 @@ def method_comment(class_name, method_name): String like "// SimpleStruct.printNewFunction" """ return f"// generated by {class_name}.{method_name}" + + @staticmethod + def method_comment_with_impl(obj, method_name): + """ + Generate class.method comment with implementing class if different. + + Uses introspection to find the class where the method is actually + defined. If it differs from the object's class, both are shown. + + Args: + obj: The object instance (not the class) + method_name: Name of the method + + Returns: + String like: + - "// generated by SimpleStruct.printNewFunction" if method defined in SimpleStruct + - "// generated by SimpleStruct (Base).printNewFunction" if inherited from Base + """ + obj_class_name = obj.__class__.__name__ + + # Find the class where the method is actually defined + impl_class_name = None + for cls in inspect.getmro(obj.__class__): + if method_name in cls.__dict__: + impl_class_name = cls.__name__ + break + + # If we found the implementing class and it's different from the object's class + if impl_class_name and impl_class_name != obj_class_name: + return f"// generated by {obj_class_name}.{impl_class_name}.{method_name}" + else: + return f"// generated by {obj_class_name}.{method_name}" diff --git a/tools/generate/compare_helper.py b/tools/generate/compare_helper.py index f940f1f7..ab005650 100644 --- a/tools/generate/compare_helper.py +++ b/tools/generate/compare_helper.py @@ -1,52 +1,53 @@ """ -Compare Helper - Utilities for handling extra comparison arguments. +Eq Helper - Utilities for handling extra equality function arguments. -This module provides utilities for managing extra comparison function parameters +This module provides utilities for managing extra equality function parameters that some types need (e.g., comparing arrays may need size information). """ -class CompareHelper: +class EqHelper: """ - Utilities for generating extra comparison function parameters. + Utilities for generating extra equality function parameters. - Some entity types can have additional arguments for their comparison functions - defined via the extraCmpArgs dictionary in their YAML. + Some entity types can have additional arguments for their equality functions + defined via the extraEqArgs dictionary in their YAML. """ @staticmethod - def get_extra_formal_args(extra_cmp_args, get_ctype_fn): + def get_extra_formal_args(extra_eq_args, get_ctype_fn): """ - Generate formal parameter string for extra comparison arguments. + Generate formal parameter string for extra equality arguments. Args: - extra_cmp_args: Dictionary mapping arg names to type names + extra_eq_args: Dictionary mapping arg names to type names get_ctype_fn: Function to convert type name to C type declaration Returns: String like ", Type1 arg1, Type2 arg2" or "" if no extra args """ extra = [] - for name in extra_cmp_args: - ctype = get_ctype_fn(extra_cmp_args[name]) + for name in extra_eq_args: + ctype = get_ctype_fn(extra_eq_args[name]) extra.append(f"{ctype}{name}") if len(extra) > 0: return ", " + ", ".join(extra) return "" @staticmethod - def get_extra_actual_args(extra_cmp_args): + def get_extra_actual_args(extra_eq_args): """ - Generate actual argument string for extra comparison arguments. + Generate actual argument string for extra equality arguments. Args: - extra_cmp_args: Dictionary mapping arg names to type names + extra_eq_args: Dictionary mapping arg names to type names Returns: String like ", arg1, arg2" or "" if no extra args """ extra = [] - for name in extra_cmp_args: + for name in extra_eq_args: extra.append(name) if len(extra) > 0: return ", " + ", ".join(extra) return "" + diff --git a/tools/generate/discriminated_union.py b/tools/generate/discriminated_union.py index 08c473c4..472c355a 100644 --- a/tools/generate/discriminated_union.py +++ b/tools/generate/discriminated_union.py @@ -22,8 +22,8 @@ def __init__(self, name, body): self.enum = DiscriminatedUnionEnum(self.name, self.fields, body) def build(self, catalog): - catalog.add(self.union) - catalog.add(self.enum) + catalog.add(self.union, self.isExternal()) + catalog.add(self.enum, self.isExternal()) def makeField(self, fieldName, fieldData): return DiscriminatedUnionField(self.name, fieldName, fieldData) @@ -81,14 +81,14 @@ def printMarkFunctionBody(self, catalog): print(f' cant_happen("unrecognised type %d in mark{myName}", _x{a}type); {c}') print(f" }} {c}") - def printCompareFunctionBody(self, catalog): - c = self.comment('printCompareFunctionBody') + def printEqFunctionBody(self, catalog): + c = self.comment('printEqFunctionBody') myName=self.getName() a = AccessorHelper.accessor(self.isInline(catalog)) print(f" if (a{a}type != b{a}type) return false; {c}") print(f" switch(a{a}type) {{ {c}") for field in self.fields: - field.printCompareCase(self.isInline(catalog), catalog) + field.printEqCase(self.isInline(catalog), catalog) print(f" default: {c}") print(f' cant_happen("unrecognised type %d in eq{myName}", a{a}type); {c}') print(f" }} {c}") diff --git a/tools/generate/discriminated_union_field.py b/tools/generate/discriminated_union_field.py index e1508fd6..56741a27 100644 --- a/tools/generate/discriminated_union_field.py +++ b/tools/generate/discriminated_union_field.py @@ -222,12 +222,12 @@ def printProtectCase(self, isInline, catalog): obj = catalog.get(self.typeName) obj.printProtectField(isInline, self.name, 3, 'val.') - def printCompareCase(self, isInline, catalog): - c = self.comment('printCompareCase') + def printEqCase(self, isInline, catalog): + c = self.comment('printEqCase') typeName = self.makeTypeName() print(f" case {typeName}: {c}") obj = catalog.get(self.typeName) - obj.printCompareField(catalog, isInline, self.name, 3, 'val.') + obj.printEqField(catalog, isInline, self.name, 3, 'val.') print(f" break; {c}") def printPrintCase(self, catalog, isInline): diff --git a/tools/generate/enum_field.py b/tools/generate/enum_field.py index 32447918..8bc6cca5 100644 --- a/tools/generate/enum_field.py +++ b/tools/generate/enum_field.py @@ -63,8 +63,8 @@ def makeTypeName(self): v = v.upper().replace('AST', 'AST_') return v - def printCompareCase(self, depth): - c = self.comment('printCompareCase') + def printEqCase(self, depth): + c = self.comment('printEqCase') typeName = self.makeTypeName() pad(depth) print(f'case {typeName}: {c}') diff --git a/tools/generate/hashes.py b/tools/generate/hashes.py index 481abaf9..8d18755c 100644 --- a/tools/generate/hashes.py +++ b/tools/generate/hashes.py @@ -240,8 +240,8 @@ def printPrintField(self, isInline, field, depth, prefix=''): pad(depth) print(f'printHashTable((HashTable *)_x{a}{prefix}{field}, depth + 1); {c}') - def printCompareField(self, catalog, isInline, field, depth, prefix=''): - c = self.comment('printCompareField') + def printEqField(self, catalog, isInline, field, depth, prefix=''): + c = self.comment('printEqField') pad(depth) print(f"return false; {c}") diff --git a/tools/generate/inline_array.py b/tools/generate/inline_array.py index 0efcdc1b..fd076436 100644 --- a/tools/generate/inline_array.py +++ b/tools/generate/inline_array.py @@ -14,7 +14,7 @@ from .type_helper import TypeHelper from .signature_helper import SignatureHelper from .accessor_helper import AccessorHelper -from .compare_helper import CompareHelper +from .compare_helper import EqHelper from .objtype_helper import ObjectTypeHelper diff --git a/tools/generate/kontinuations.py b/tools/generate/kontinuations.py index 7103a314..9cd5e7d2 100644 --- a/tools/generate/kontinuations.py +++ b/tools/generate/kontinuations.py @@ -63,14 +63,14 @@ def populate_catalog(self, catalog: Catalog) -> None: } # Add struct to catalog - catalog.add(SimpleStruct(struct_name, struct_yaml)) + catalog.add(SimpleStruct(struct_name, struct_yaml), False) # Add to union mapping union_data[key] = struct_name # Add discriminated union to catalog union_yaml = {'data': union_data} - catalog.add(DiscriminatedUnion(kont_env_union, union_yaml)) + catalog.add(DiscriminatedUnion(kont_env_union, union_yaml), False) # Add continuation struct with parameterized name catalog.add(SimpleStruct(kont_struct, { @@ -81,7 +81,7 @@ def populate_catalog(self, catalog: Catalog) -> None: 'env': kont_env_union, 'wrapper': wrapper_type } - })) + }), False) def generate_kont_impl_inc(self, output: TextIO, catalog: Catalog, includes) -> None: self._write_header(output, includes, 'inc') diff --git a/tools/generate/loader.py b/tools/generate/loader.py index 904be271..35d023a8 100644 --- a/tools/generate/loader.py +++ b/tools/generate/loader.py @@ -27,12 +27,17 @@ class Loader(yaml.SafeLoader): """YAML loader that supports !include directive for file inclusion""" + _visited_files = set() + def __init__(self, stream): self._root = os.path.split(stream.name)[0] super(Loader, self).__init__(stream) def include(self, node): fileName = os.path.join(self._root, self.construct_scalar(node)) + if fileName in self._visited_files: + return {} + self._visited_files.add(fileName) with open(fileName, 'r') as f: return yaml.load(f, Loader) diff --git a/tools/generate/primitives.py b/tools/generate/primitives.py index 1fc36a96..e481d2cf 100644 --- a/tools/generate/primitives.py +++ b/tools/generate/primitives.py @@ -40,16 +40,24 @@ def __init__(self, name, body): self.markFn = data['markFn'] else: self.markFn = None + if 'newFn' in data: + self.newFn = data['newFn'] + else: + self.newFn = None if 'printf' in data: self.printFn = 'printf' self.printf = data['printf'] else: self.printFn = data['printFn'] self.valued = data['valued'] - if 'compareFn' in data: - self.compareFn = data['compareFn'] + if 'eqFn' in data: + self.eqFn = data['eqFn'] + else: + self.eqFn = None + if 'cmpFn' in data: + self.cmpFn = data['cmpFn'] else: - self.compareFn = None + self.cmpFn = None if 'copyFn' in data: self.copyFn = data['copyFn'] else: @@ -94,7 +102,10 @@ def printMarkField(self, isInline, field, depth, prefix=''): markFn=self.markFn pad(depth) a = '.' if isInline else '->' - print(f"{markFn}(_x{a}{prefix}{field}); {c}") + if markFn == 'markHashTable': + print(f'{markFn}((HashTable *)(_x{a}{prefix}{field})); {c}') + else: + print(f"{markFn}(_x{a}{prefix}{field}); {c}") def printProtectField(self, isInline, field, depth, prefix=''): c = self.comment('printProtectField') @@ -108,14 +119,18 @@ def printProtectField(self, isInline, field, depth, prefix=''): def getTypeDeclaration(self, catalog): return TypeHelper.primitive_type(self.cname) - def printCompareField(self, catalog, isInline, field, depth, prefix=''): - c = self.comment('printCompareField') + def printEqField(self, catalog, isInline, field, depth, prefix=''): + c = self.comment('printEqField') pad(depth) a = '.' if isInline else '->' - if self.compareFn is None: - print(f"if (a{a}{prefix}{field} != b{a}{prefix}{field}) return false; {c}") + # use the custom equality function if provided + if self.eqFn is not None: + print(f"if (!{self.eqFn}(a{a}{prefix}{field}, b{a}{prefix}{field})) return false; {c}") + elif self.cmpFn is not None: + # cmpFn returns enum Cmp, so compare with CMP_EQ + print(f"if ({self.cmpFn}(a{a}{prefix}{field}, b{a}{prefix}{field}) != CMP_EQ) return false; {c}") else: - print(f"if ({self.compareFn}(a{a}{prefix}{field}, b{a}{prefix}{field})) return false; {c}") + print(f"if (a{a}{prefix}{field} != b{a}{prefix}{field}) return false; {c}") def printPrintHashField(self, depth): c = self.comment('printPrintHashField') @@ -146,6 +161,9 @@ def printCopyField(self, isInline, field, depth, prefix=''): a = '.' if isInline else '->' if self.copyFn is None: print(f"_x{a}{prefix}{field} = o{a}{prefix}{field}; {c}") + elif self.copyFn == 'copyHashTable': + print(f'_x{a}{prefix}{field} = {self.newFn}(); {c}') + print(f'copyHashTable((HashTable *)_x{a}{prefix}{field}, (HashTable *)o{a}{prefix}{field}); {c}') else: print(f"_x{a}{prefix}{field} = {self.copyFn}(o{a}{prefix}{field}); {c}") @@ -154,3 +172,11 @@ def getDefineValue(self): def getDefineArg(self): return '_x' if self.valued else '' + + def isSelfInitializing(self): + return self.newFn is not None + + def getConstructorName(self): + if self.newFn is None: + raise ValueError(f"Primitive {self.name} has no known constructor") + return self.newFn \ No newline at end of file diff --git a/tools/generate/signature_helper.py b/tools/generate/signature_helper.py index 0a1e3298..d5c1716d 100644 --- a/tools/generate/signature_helper.py +++ b/tools/generate/signature_helper.py @@ -14,7 +14,7 @@ class SignatureHelper: - free: void freeName(Type _x) - print: void printName(Type _x, int depth) - copy: Type copyName(Type _x) - - compare: bool eqName(Type a, Type b) + - eq: bool eqName(Type a, Type b) - new: Type newName(...args) """ @@ -39,9 +39,9 @@ def copy_signature(name, type_decl): return f"{type_decl} copy{name}({type_decl} o)" @staticmethod - def compare_signature(name, type_decl, extra_args=""): + def eq_signature(name, type_decl, extra_args=""): """ - Generate compare function signature: bool eqName(Type a, Type b[, extra...]) + Generate equality function signature: bool eqName(Type a, Type b[, extra...]) Args: name: Function base name diff --git a/tools/generate/simple_array.py b/tools/generate/simple_array.py index 6ea58b60..3761bdda 100644 --- a/tools/generate/simple_array.py +++ b/tools/generate/simple_array.py @@ -14,7 +14,7 @@ from .type_helper import TypeHelper from .signature_helper import SignatureHelper from .accessor_helper import AccessorHelper -from .compare_helper import CompareHelper +from .compare_helper import EqHelper from .objtype_helper import ObjectTypeHelper @@ -55,13 +55,13 @@ def tag(self): def getTypeDeclaration(self, catalog): return TypeHelper.struct_type(self.getName(), self.isInline(catalog)) - def printCompareField(self, catalog, isInline, field, depth, prefix=''): + def printEqField(self, catalog, isInline, field, depth, prefix=''): myName=self.getName() - extraCmpArgs = self.getExtraCmpAargs(catalog) + extraEqArgs = self.getExtraEqAargs(catalog) a = AccessorHelper.accessor(isInline) - c = self.comment('printCompareField') + c = self.comment('printEqField') pad(depth) - print(f"if (!eq{myName}(a{a}{prefix}{field}, b{a}{prefix}{field}{extraCmpArgs})) return false; {c}") + print(f"if (!eq{myName}(a{a}{prefix}{field}, b{a}{prefix}{field}{extraEqArgs})) return false; {c}") def printCopyField(self, isInline, field, depth, prefix=''): myName=self.getName() @@ -263,6 +263,22 @@ def printCopyDeclaration(self, catalog): decl=self.getCopySignature(catalog) print(f"{decl}; {c}") + def printAppendDeclaration(self, catalog): + if self.dimension == 1: + name = self.getName() + myType = self.getTypeDeclaration(catalog) + a = '*' if self.isInline(catalog) else '' + c = self.comment('printAppendDeclaration') + print(f"void append{name}({myType} {a}dest, {myType} {a}src); {c}") + + def printAddDeclaration(self, catalog): + if self.dimension == 1: + name = self.getName() + myType = self.getTypeDeclaration(catalog) + a = '*' if self.isInline(catalog) else '' + c = self.comment('printAddDeclaration') + print(f"void add{name}({myType} {a}obj, Index size); {c}") + def printExtendDeclaration(self, catalog): if self.dimension == 1: name = self.getName() @@ -388,6 +404,43 @@ def printPokeDeclaration(self, catalog): c = self.comment('printPokeDeclaration') print(f"void poke{name}({myType} {a}obj, int offset, {entryType} val); {c}") + def printAppendFunction(self, catalog): + if self.dimension == 1: + name = self.getName() + myType = self.getTypeDeclaration(catalog) + entryType = self.entries.getTypeDeclaration(catalog) + c = self.comment('printAppendFunction') + a = '*' if self.isInline(catalog) else '' + print(f"/**") + print(f" * Appends all entries from `src` to the end of `dest`,") + print(f" * extending `dest` if required.") + print(f" */") + print(f"void append{name}({myType} {a}dest, {myType} {a}src) {{ {c}") + print(f' DEBUG("append{name}(%p, %p)", dest, src);') + print(f" if (src->size > 0) {{ {c}") + print(f" add{name}(dest, src->size); {c}") + print(f" for (Index i = 0; i < src->size; i++) {{ {c}") + print(f" push{name}(dest, src->entries[i]); {c}") + print(f" }} {c}") + print(f" }} {c}") + print(f"}} {c}\n") + + def printAddFunction(self, catalog): + if self.dimension == 1: + name = self.getName() + myType = self.getTypeDeclaration(catalog) + c = self.comment('printAddFunction') + a = '*' if self.isInline(catalog) else '' + print(f"/**") + print(f" * Adds at least `size` capacity to the {myType} `_x`.") + print(f" * additional capacity is calculated from the current size,") + print(f" * not the current capacity.") + print(f" */") + print(f"void add{name}({myType} {a}_x, Index size) {{ {c}") + print(f' DEBUG("add{name}(%p, %u)", _x, size);') + print(f" extend{name}(_x, _x->size + size); {c}") + print(f"}} {c}\n") + def printExtendFunction(self, catalog): if self.dimension == 1: name = self.getName() @@ -701,9 +754,9 @@ def printPrintDeclaration(self, catalog): decl=self.getPrintSignature(catalog) print(f"{decl}; {c}") - def printCompareDeclaration(self, catalog): - c = self.comment('printCompareDeclaration') - decl=self.getCompareSignature(catalog) + def printEqDeclaration(self, catalog): + c = self.comment('printEqDeclaration') + decl=self.getEqSignature(catalog) print(f"{decl}; {c}") def getPrintSignature(self, catalog): @@ -726,27 +779,27 @@ def printCountDeclaration(self, catalog): print(f'}} {c}') print('') - def getExtraCmpFargs(self, catalog): - return CompareHelper.get_extra_formal_args(self.extraCmpArgs, lambda t: self.getCtype(t, catalog)) + def getExtraEqFargs(self, catalog): + return EqHelper.get_extra_formal_args(self.extraEqArgs, lambda t: self.getCtype(t, catalog)) - def getExtraCmpAargs(self, catalog): - return CompareHelper.get_extra_actual_args(self.extraCmpArgs) + def getExtraEqAargs(self, catalog): + return EqHelper.get_extra_actual_args(self.extraEqArgs) - def getCompareSignature(self, catalog): + def getEqSignature(self, catalog): myType = self.getTypeDeclaration(catalog) myName = self.getName() - extraCmpArgs = self.getExtraCmpFargs(catalog) - return SignatureHelper.compare_signature(myName, myType, extraCmpArgs) + extraEqArgs = self.getExtraEqFargs(catalog) + return SignatureHelper.eq_signature(myName, myType, extraEqArgs) - def printCompareFunction(self, catalog): - c = self.comment('printCompareFunction') - if self.bespokeCmpImplementation: + def printEqFunction(self, catalog): + c = self.comment('printEqFunction') + if self.bespokeEqImplementation: print("// Bespoke implementation required for") - print("// {decl}".format(decl=self.getCompareSignature(catalog))) + print("// {decl}".format(decl=self.getEqSignature(catalog))) print("") return myName = self.getName() - decl = self.getCompareSignature(catalog) + decl = self.getEqSignature(catalog) a = AccessorHelper.accessor(self.isInline(catalog)) print(f"/**") print(f" * @brief Deep compare two {myName} objects for equality.") @@ -758,12 +811,12 @@ def printCompareFunction(self, catalog): if self.dimension == 1: print(f" if (a{a}size != b{a}size) return false; {c}") print(f" for (Index i = 0; i < a{a}size; i++) {{ {c}") - self.entries.printCompareArrayLine(self.isInline(catalog), catalog, "i", 2) + self.entries.printEqArrayLine(self.isInline(catalog), catalog, "i", 2) print(f" }} {c}") else: print(f" if (a{a}width != b{a}width || a{a}height != b{a}height) return false; {c}") print(f" for (Index i = 0; i < (a{a}width * a{a}height); i++) {{ {c}") - self.entries.printCompareArrayLine(self.isInline(catalog), catalog, "i", 2) + self.entries.printEqArrayLine(self.isInline(catalog), catalog, "i", 2) print(f" }} {c}") print(f" return true; {c}") print(f"}} {c}\n") diff --git a/tools/generate/simple_enum.py b/tools/generate/simple_enum.py index d53a8029..ab9c98b1 100644 --- a/tools/generate/simple_enum.py +++ b/tools/generate/simple_enum.py @@ -75,13 +75,13 @@ def needsProtection(self, catalog): """Enums don't need GC protection""" return False - def printCompareField(self, catalog, isInline, field, depth, prefix=''): + def printEqField(self, catalog, isInline, field, depth, prefix=''): pad(depth) - c = self.comment('printCompareField') + c = self.comment('printEqField') a = '.' if isInline else '->' print(f"switch (a{a}{prefix}{field}) {{ {c}") for field in self.fields: - field.printCompareCase(depth + 1) + field.printEqCase(depth + 1) pad(depth) print(f'}} {c}') diff --git a/tools/generate/simple_field.py b/tools/generate/simple_field.py index cc43217b..e24ff453 100644 --- a/tools/generate/simple_field.py +++ b/tools/generate/simple_field.py @@ -111,9 +111,9 @@ def printPrintHashLine(self, catalog, depth): obj = catalog.get(self.typeName) obj.printPrintHashField(depth) - def printCompareLine(self, isInline, catalog, depth): + def printEqLine(self, isInline, catalog, depth): obj = catalog.get(self.typeName) - obj.printCompareField(catalog, isInline, self.name, depth) + obj.printEqField(catalog, isInline, self.name, depth) def printPrintLine(self, isInline, catalog, depth): obj = catalog.get(self.typeName) @@ -131,9 +131,9 @@ def printCopyArrayLine(self, catalog, key, depth): obj = catalog.get(self.typeName) obj.printCopyField(obj.isInline(catalog), f"{self.name}[{key}]", depth) - def printCompareArrayLine(self, isInline, catalog, key, depth): + def printEqArrayLine(self, isInline, catalog, key, depth): obj = catalog.get(self.typeName) - obj.printCompareField(catalog, isInline, f"{self.name}[{key}]", depth) + obj.printEqField(catalog, isInline, f"{self.name}[{key}]", depth) def printStructTypedefLine(self, catalog): c = self.comment('printStructTypedefLine') diff --git a/tools/generate/simple_stack.py b/tools/generate/simple_stack.py index 528de75d..9ad1cf3a 100644 --- a/tools/generate/simple_stack.py +++ b/tools/generate/simple_stack.py @@ -14,7 +14,7 @@ from .type_helper import TypeHelper from .signature_helper import SignatureHelper from .accessor_helper import AccessorHelper -from .compare_helper import CompareHelper +from .compare_helper import EqHelper from .objtype_helper import ObjectTypeHelper @@ -79,13 +79,23 @@ def printInitEntries(self, catalog): print(f" _x->frames = NEW_ARRAY(StackFrame, 8); {c}") print(f" _x->frames_capacity = 8; {c}") + def printAddDeclaration(self, catalog): + if self.dimension == 1: + name = self.getName() + myType = self.getTypeDeclaration(catalog) + a = '*' if self.isInline(catalog) else '' + c = self.comment('printAddDeclaration') + print(f"void add{name}Entries({myType} {a}obj, Index size); {c}") + print(f"void add{name}Frames({myType} {a}obj, Index size); {c}") + def printExtendDeclaration(self, catalog): - name = self.getName() - myType = self.getTypeDeclaration(catalog) - a = '*' if self.isInline(catalog) else '' - c = self.comment('printExtendDeclaration') - print(f"void extend{name}Entries({myType} {a}obj, Index size); {c}") - print(f"void extend{name}Frames({myType} {a}obj, Index size); {c}") + if self.dimension == 1: + name = self.getName() + myType = self.getTypeDeclaration(catalog) + a = '*' if self.isInline(catalog) else '' + c = self.comment('printExtendDeclaration') + print(f"void extend{name}Entries({myType} {a}obj, Index size); {c}") + print(f"void extend{name}Frames({myType} {a}obj, Index size); {c}") def printSizeDeclaration(self, catalog): name = self.getName() @@ -144,6 +154,36 @@ def printClearDeclaration(self, catalog): print(f"static inline void clear{name}Entries({myType} {a}_x) {{ _x->offset = 0; }}; {c}") print(f"static inline void clear{name}Frames({myType} {a}_x) {{ _x->frames_index = _x->offset = _x->frame = 0; }}; {c}") + def printAppendDeclaration(self, catalog): + pass + + def printAppendFunction(self, catalog): + pass + + def printAddFunction(self, catalog): + if self.dimension == 1: + name = self.getName() + myType = self.getTypeDeclaration(catalog) + c = self.comment('printAddFunction') + a = '*' if self.isInline(catalog) else '' + print(f"/**") + print(f" * Adds at leat `size` capacity to the {myType}.") + print(f" */") + print(f"void add{name}Entries({myType} {a}_x, Index size) {{ {c}") + print(f' DEBUG("add{name}Entries(%p, %u)", _x, size);') + print(f" extend{name}Entries(_x, _x->entries_capacity + size); {c}") + print(f"}} {c}") + print(f"") + print(f"/**") + print(f" * Adds at least `size` capacity to the {myType} frames.") + print(f" */") + print(f"void add{name}Frames({myType} {a}_x, Index size) {{ {c}") + print(f' DEBUG("add{name}Frames(%p, %u)", _x, size);') + print(f" extend{name}Frames(_x, _x->frames_capacity + size); {c}") + print(f"}} {c}") + print(f"") + + def printExtendFunction(self, catalog): if self.dimension == 1: name = self.getName() @@ -545,10 +585,10 @@ def printCountDeclaration(self, catalog): print(f'}} {c}') print('') - def printCompareFunction(self, catalog): - c = self.comment('printCompareFunction') - decl = self.getCompareSignature(catalog) - if self.bespokeCmpImplementation: + def printEqFunction(self, catalog): + c = self.comment('printEqFunction') + decl = self.getEqSignature(catalog) + if self.bespokeEqImplementation: print(f"// Bespoke implementation required for {decl}") print("") return @@ -567,7 +607,7 @@ def printCompareFunction(self, catalog): print(f" if (a->frames[i].offset != b->frames[i].offset) return false; {c}") print(f" }} {c}") print(f" for (Index i = 0; i < a->frame + a->offset; i++) {{ {c}") - self.entries.printCompareArrayLine(self.isInline(catalog), catalog, "i", 2) + self.entries.printEqArrayLine(self.isInline(catalog), catalog, "i", 2) print(f" }} {c}") print(f" return true; {c}") print(f"}} {c}") diff --git a/tools/generate/simple_struct.py b/tools/generate/simple_struct.py index 05bf72f3..30855f5a 100644 --- a/tools/generate/simple_struct.py +++ b/tools/generate/simple_struct.py @@ -10,7 +10,7 @@ from .type_helper import TypeHelper from .signature_helper import SignatureHelper from .accessor_helper import AccessorHelper -from .compare_helper import CompareHelper +from .compare_helper import EqHelper from .objtype_helper import ObjectTypeHelper class SimpleStruct(Base): @@ -118,17 +118,17 @@ def getPrintSignature(self, catalog): def getCtype(self, astType, catalog): return TypeHelper.pointer_type(astType) - def getExtraCmpFargs(self, catalog): - return CompareHelper.get_extra_formal_args(self.extraCmpArgs, lambda t: self.getCtype(t, catalog)) + def getExtraEqFargs(self, catalog): + return EqHelper.get_extra_formal_args(self.extraEqArgs, lambda t: self.getCtype(t, catalog)) - def getExtraCmpAargs(self, catalog): - return CompareHelper.get_extra_actual_args(self.extraCmpArgs) + def getExtraEqAargs(self, catalog): + return EqHelper.get_extra_actual_args(self.extraEqArgs) - def getCompareSignature(self, catalog): + def getEqSignature(self, catalog): myType = self.getTypeDeclaration(catalog) myName = self.getName() - extraCmpArgs = self.getExtraCmpFargs(catalog) - return SignatureHelper.compare_signature(myName, myType, extraCmpArgs) + extraEqArgs = self.getExtraEqFargs(catalog) + return SignatureHelper.eq_signature(myName, myType, extraEqArgs) def getNewArgs(self, catalog): return [_x for _x in self.fields if _x.default is None and not _x.isSelfInitializing(catalog)] @@ -179,9 +179,9 @@ def printPrintDeclaration(self, catalog): decl=self.getPrintSignature(catalog) print(f"{decl}; {c}") - def printCompareDeclaration(self, catalog): - c = self.comment('printCompareDeclaration') - decl=self.getCompareSignature(catalog) + def printEqDeclaration(self, catalog): + c = self.comment('printEqDeclaration') + decl=self.getEqSignature(catalog) print(f"{decl}; {c}") def printNewFunction(self, catalog): @@ -227,9 +227,15 @@ def printMarkFunctionBody(self, catalog): for field in self.fields: field.printMarkLine(self.isInline(catalog), catalog, 1) - def printCompareFunctionBody(self, catalog): + def printEqFunctionBody(self, catalog): + c = self.comment('printEqFunctionBody') for field in self.fields: - field.printCompareLine(self.isInline(catalog), catalog, 1) + # Check if this field should be ignored in equality comparison + if field.getName() in self.eqIgnore: + pad(1) + print(f"// field '{field.getName()}' deliberately ignored in equality comparison {c}") + else: + field.printEqLine(self.isInline(catalog), catalog, 1) def printCopyFunctionBody(self, catalog): for field in self.fields: @@ -261,13 +267,17 @@ def printProtectField(self, isInline, field, depth, prefix=''): a = AccessorHelper.accessor(isInline) print(f"return PROTECT(_x{a}{prefix}{field}); {c}") - def printCompareField(self, catalog, isInline, field, depth, prefix=''): - c = self.comment('printCompareField') - myName=self.getName() - extraArgs = self.getExtraCmpAargs({}) + def printEqField(self, catalog, isInline, field, depth, prefix=''): + c = self.comment('printEqField') + myName = self.getName() + extraArgs = self.getExtraEqAargs({}) a = AccessorHelper.accessor(isInline) pad(depth) - print(f"if (!eq{myName}(a{a}{prefix}{field}, b{a}{prefix}{field}{extraArgs})) return false; {c}") + if self.isExternal() and extraArgs != "": + # We don't have access to those extra args if we're not called natively + print(f"if (a{a}{prefix}{field} != b{a}{prefix}{field}) return false; {c}") + else: + print(f"if (!eq{myName}(a{a}{prefix}{field}, b{a}{prefix}{field}{extraArgs})) return false; {c}") def printPrintHashField(self, depth): c = self.comment('printPrintHashField') @@ -351,15 +361,15 @@ def printTypeObjCase(self, catalog): pad(3) print(f'return "{name}"; {c}') - def printCompareFunction(self, catalog): - if self.bespokeCmpImplementation: + def printEqFunction(self, catalog): + if self.bespokeEqImplementation: print("// Bespoke implementation required for") - print("// {decl}".format(decl=self.getCompareSignature(catalog))) + print("// {decl}".format(decl=self.getEqSignature(catalog))) print("") return myName = self.getName() - c = self.comment('printCompareFunction') - decl=self.getCompareSignature(catalog) + c = self.comment('printEqFunction') + decl=self.getEqSignature(catalog) print(f"/**") print(f" * Compares two {myName} objects for equality.") print(f" * It will recursively compare all the fields of the object.") @@ -368,7 +378,7 @@ def printCompareFunction(self, catalog): if not self.isInline(catalog): print(f" if (a == b) return true; {c}") print(f" if (a == NULL || b == NULL) return false; {c}") - self.printCompareFunctionBody(catalog) + self.printEqFunctionBody(catalog) print(f" return true; {c}") print(f"}} {c}\n") diff --git a/tools/generate/switch_helper.py b/tools/generate/switch_helper.py index 563d758f..442265d0 100644 --- a/tools/generate/switch_helper.py +++ b/tools/generate/switch_helper.py @@ -13,13 +13,13 @@ class SwitchHelper: """ @staticmethod - def print_switch_function(catalog, method_name, func_name, param_decl, case_method, default_action, return_type='void'): + def print_switch_function(catalog, packageName, method_name, func_name, param_decl, case_method, default_action, return_type='void'): """ Print a switch-based dispatcher function. Args: catalog: The catalog containing entities - method_name: Name of the catalog method (e.g., 'printMarkObjFunction') + packageName: The package name (e.g., 'Lambda') func_name: Name of function to generate (e.g., 'mark{Type}Obj') param_decl: Parameter declaration (e.g., 'struct Header *h') case_method: Method name to call on each entity for case generation @@ -27,7 +27,7 @@ def print_switch_function(catalog, method_name, func_name, param_decl, case_meth return_type: Return type of function (default 'void') """ c = CommentGen.method_comment('Catalog', method_name) - type_cap = catalog.typeName.capitalize() + type_cap = packageName.capitalize() func_full_name = func_name.format(Type=type_cap) print(f'{return_type} {func_full_name}({param_decl}) {{ {c}') @@ -38,8 +38,9 @@ def print_switch_function(catalog, method_name, func_name, param_decl, case_meth # Generate cases from entities for entity in catalog.contents.values(): - method = getattr(entity, case_method) - method(catalog) + if not entity.isExternal(): + method = getattr(entity, case_method) + method(catalog) # Default case print(f' default: {c}') diff --git a/tools/generate/vectors.py b/tools/generate/vectors.py index 3bd159a6..ef51f396 100644 --- a/tools/generate/vectors.py +++ b/tools/generate/vectors.py @@ -12,7 +12,7 @@ from .type_helper import TypeHelper from .signature_helper import SignatureHelper from .accessor_helper import AccessorHelper -from .compare_helper import CompareHelper +from .compare_helper import EqHelper from .objtype_helper import ObjectTypeHelper @@ -106,19 +106,19 @@ def printPrintField(self, isInline, field, depth, prefix=''): pad(depth) print(f'print{myName}(_x{a}{prefix}{field}, depth+1); {c}') - def printCompareField(self, catalog, isInline, field, depth, prefix=''): - c = self.comment('printCompareField') + def printEqField(self, catalog, isInline, field, depth, prefix=''): + c = self.comment('printEqField') myName=self.getName() - extraCmpArgs = self.getExtraCmpAargs(catalog) + extraEqArgs = self.getExtraEqAargs(catalog) a = '.' if isInline else '->' pad(depth) - print(f"if (!eq{myName}(a{a}{prefix}{field}, b{a}{prefix}{field}{extraCmpArgs})) return false; {c}") + print(f"if (!eq{myName}(a{a}{prefix}{field}, b{a}{prefix}{field}{extraEqArgs})) return false; {c}") - def getExtraCmpFargs(self, catalog): - return CompareHelper.get_extra_formal_args(self.extraCmpArgs, lambda t: self.getCtype(t, catalog)) + def getExtraEqFargs(self, catalog): + return EqHelper.get_extra_formal_args(self.extraEqArgs, lambda t: self.getCtype(t, catalog)) - def getExtraCmpAargs(self, catalog): - return CompareHelper.get_extra_actual_args(self.extraCmpArgs) + def getExtraEqAargs(self, catalog): + return EqHelper.get_extra_actual_args(self.extraEqArgs) def objTypeArray(self): return ObjectTypeHelper.obj_type_array(self.getName()) @@ -174,16 +174,16 @@ def printPrintDeclaration(self, catalog): decl=self.getPrintSignature(catalog) print(f"{decl}; {c}") - def printCompareDeclaration(self, catalog): - c = self.comment('printCompareDeclaration') - decl=self.getCompareSignature(catalog) + def printEqDeclaration(self, catalog): + c = self.comment('printEqDeclaration') + decl=self.getEqSignature(catalog) print(f"{decl}; {c}") - def getCompareSignature(self, catalog): + def getEqSignature(self, catalog): myType = self.getTypeDeclaration(catalog) myName = self.getName() - extraCmpArgs = self.getExtraCmpFargs(catalog) - return SignatureHelper.compare_signature(myName, myType, extraCmpArgs) + extraEqArgs = self.getExtraEqFargs(catalog) + return SignatureHelper.eq_signature(myName, myType, extraEqArgs) def printMarkFunction(self, catalog): decl = self.getMarkSignature(catalog) @@ -202,15 +202,15 @@ def printMarkFunction(self, catalog): print(f"}} {c}") print("") - def printCompareFunction(self, catalog): - decl = self.getCompareSignature(catalog) - if self.bespokeCmpImplementation: + def printEqFunction(self, catalog): + decl = self.getEqSignature(catalog) + if self.bespokeEqImplementation: print("// Bespoke implementation required for") print(f"// {decl}") print("") return myName = self.getName() - c = self.comment('printCompareFunction') + c = self.comment('printEqFunction') print(f"/**") print(f" * Compares two {myName} vectors for deep equality.") print(f" */") @@ -219,7 +219,7 @@ def printCompareFunction(self, catalog): print(f" if (a == NULL || b == NULL) return false; {c}") print(f" if (a->size != b->size) return false; {c}") print(f" for (Index i = 0; i < a->size; i++) {{ {c}") - self.entries.printCompareArrayLine(False, catalog, "i", 2) + self.entries.printEqArrayLine(False, catalog, "i", 2) print(f" }} {c}") print(f" return true; {c}") print(f"}} {c}") diff --git a/utils.sh b/utils.sh index b488b13c..1df25d9e 100644 --- a/utils.sh +++ b/utils.sh @@ -102,4 +102,6 @@ new_visitor () { fi new_h "$1_$2" && python3 tools/generate.py --target "$2" src/$1.yaml visitor > $cfile -} \ No newline at end of file +} + +export PATH=./bin:$PATH \ No newline at end of file diff --git a/vscode/fn/syntaxes/fn.tmLanguage.json b/vscode/fn/syntaxes/fn.tmLanguage.json index 066ea61b..fbac75f1 100644 --- a/vscode/fn/syntaxes/fn.tmLanguage.json +++ b/vscode/fn/syntaxes/fn.tmLanguage.json @@ -40,10 +40,12 @@ "patterns": [] }, "keywords": { - "patterns": [{ - "name": "keyword.control.fn", - "match": "\\b(namespace|switch|if|else|back|here|error|typedef|alias|macro|unsafe|let|in|print|assert|link|import|export|as)\\b" - }] + "patterns": [ + { + "name": "keyword.control.fn", + "match": "\\b(from|some|total|one|except|then|namespace|switch|if|else|back|here|error|typedef|alias|macro|unsafe|let|in|print|assert|link|import|export|as)\\b" + } + ] }, "strings": { "name": "string.quoted.double.fn", @@ -72,16 +74,18 @@ "match": "\\b(0x)?\\d(_|\\d)*(\\.\\d(_|\\d)*)?i?\\b" }, "constants": { - "patterns": [{ - "name": "constant.language.fn", - "match": "\\b(true|false|nil|left|right|none|operators|operator|_|lt|eq|gt|nothing|some|argv|failure|success)\\b" - }] + "patterns": [ + { + "name": "constant.language.fn", + "match": "\\b(true|false|nil|left|right|none|operators|operator|_|lt|eq|gt|nothing|just|argv|failure|success)\\b" + } + ] }, "operators": { "patterns": [ { "name": "keyword.operator.fn", - "match": "\\b(and|or|not|xor|nor|xnor|nand|of|then)\\b" + "match": "\\b(and|or|not|xor|nor|xnor|nand|of)\\b" } ] },