pub const PRELUDE_SOURCE: &str = ";;; Grift Scheme Prelude\n;;;\n;;; This file contains all standard macro definitions and library functions.\n;;; It is the single source for both compile-time StdLib enum generation\n;;; (via include_stdlib!) and runtime macro loading.\n;;;\n;;; Macro definitions (define-syntax) are evaluated at runtime.\n;;; Function definitions (define) are extracted at compile time for StdLib.\n\n;;; ============================================================\n;;; Macro Definitions\n;;; ============================================================\n\n;;; Standard Scheme Macros for Grift\n;;;\n;;; These macros are loaded at startup and provide standard R7RS-compatible\n;;; macro-based implementations of common forms.\n;;;\n;;; All macros use syntax-case for pattern matching and template expansion.\n\n;; ============================================================\n;; syntax-rules - Declarative Macro Definition (R7RS)\n;; ============================================================\n\n;; syntax-rules - Create pattern-based macro transformers\n;; \n;; (syntax-rules (literals ...) clause ...)\n;; where each clause is ((keyword . pattern) template)\n;;\n;; This expands to a lambda that uses syntax-case internally.\n;; The implementation uses nested ellipsis patterns to handle any number of clauses.\n(define-syntax syntax-rules\n (lambda (form)\n (syntax-case form ()\n ((syntax-rules (lit ...) ((keyword . pattern) template) ...)\n (syntax \n (lambda (x)\n (syntax-case x (lit ...)\n ((dummy . pattern) (syntax template)) ...)))))))\n\n;; define-syntax-rule - Convenient single-clause macro definition\n;;\n;; (define-syntax-rule (name . pattern) template)\n;; =>\n;; (define-syntax name\n;; (syntax-rules ()\n;; ((name . pattern) template)))\n(define-syntax define-syntax-rule\n (lambda (form)\n (syntax-case form ()\n ((define-syntax-rule (name . pattern) template)\n (syntax (define-syntax name\n (syntax-rules ()\n ((name . pattern) template))))))))\n\n;; ============================================================\n;; Internal Helpers\n;; ============================================================\n\n;; Helper macro for processing a single binding (used by let*)\n;; Transforms ((name val) body...) into ((lambda (name) body...) val)\n(define-syntax %let-binding\n (lambda (x)\n (syntax-case x ()\n ((%let-binding (name val) body ...) ;; Match a single binding\n (syntax ((lambda (name) body ...) val)))))) ;; Expand to lambda application\n\n;; Helper for parallel let bindings (used by regular let)\n;; Collects all variables and values, then creates a single lambda application\n(define-syntax %let-parallel-helper\n (lambda (x)\n (syntax-case x ()\n ;; Base case: all bindings processed, create lambda application\n ((%let-parallel-helper () (vars ...) (vals ...) (body ...))\n (syntax ((lambda (vars ...) body ...) vals ...)))\n ;; Recursive case: extract one var/val pair at a time\n ((%let-parallel-helper ((var val) . rest) (vars ...) (vals ...) (body ...))\n (syntax (%let-parallel-helper rest (vars ... var) (vals ... val) (body ...)))))))\n\n;; ============================================================\n;; Binding Forms (let, let*)\n;; ============================================================\n\n;; Helper for named let - single helper that builds the complete expansion\n;; Replaces the old 3-helper chain (%named-let-build -> %named-let-expand -> %named-let-extract-and-call)\n(define-syntax %named-let-helper\n (lambda (x)\n (syntax-case x ()\n ;; Base case: all bindings processed\n ((%named-let-helper loop () (vars ...) (vals ...) (body ...))\n (syntax ((lambda (vars ...)\n (letrec ((loop (lambda (vars ...) . body)))\n (loop vars ...)))\n vals ...)))\n ;; Recursive case: extract one var/val pair at a time\n ((%named-let-helper loop ((var val) . rest) (vars ...) (vals ...) (body ...))\n (syntax (%named-let-helper loop rest (vars ... var) (vals ... val) (body ...)))))))\n\n;; let - R5RS parallel binding semantics\n;; All values are evaluated first, then all bindings happen simultaneously.\n;; Supports both regular let and named let forms.\n;; Pattern order matters: more specific patterns first.\n(define-syntax let\n (lambda (x)\n (syntax-case x ()\n ;; Empty bindings - just evaluate body\n ((let () body ...)\n (syntax (begin body ...)))\n ;; Regular let with bindings - use parallel binding helper\n ((let ((var val) . rest) body ...)\n (syntax (%let-parallel-helper ((var val) . rest) () () (body ...))))\n ;; Named let: (let name bindings body ...)\n ;; name must be a symbol (not a list), followed by bindings\n ((let loop bindings body ...)\n (syntax (%named-let-helper loop bindings () () (body ...)))))))\n\n;; let* - sequential binding (each binding can refer to previous ones)\n;; Uses recursive self-reference (let* calls let*) to ensure each binding\n;; is in scope for subsequent bindings. This matches R7RS semantics.\n(define-syntax let*\n (lambda (x)\n (syntax-case x ()\n ((let* () body ...)\n (syntax (begin body ...)))\n ((let* (first-binding . rest-bindings) body ...)\n (syntax (%let-binding first-binding\n (let* rest-bindings body ...)))))))\n\n;; ============================================================\n;; Recursive Binding Forms (letrec, letrec*)\n;; ============================================================\n\n;; Two-phase helper for letrec:\n;; Phase 1: Create all bindings with undefined values\n;; Phase 2: Set all bindings to their init values\n\n;; Helper to create all undefined bindings first\n(define-syntax %letrec-names\n (lambda (x)\n (syntax-case x ()\n ;; No more bindings - now do the assignments\n ((%letrec-names () bindings body)\n (syntax (%letrec-inits bindings body)))\n ;; Create binding for first name, recurse for rest\n ((%letrec-names ((name init) . rest) bindings body)\n (syntax (let ((name #f))\n (%letrec-names rest bindings body)))))))\n\n;; Helper to assign all values after all names are bound\n(define-syntax %letrec-inits\n (lambda (x)\n (syntax-case x ()\n ;; No more bindings - evaluate body\n ((%letrec-inits () body)\n (syntax body))\n ;; Assign first binding, recurse for rest\n ((%letrec-inits ((name init) . rest) body)\n (syntax (begin\n (set! name init)\n (%letrec-inits rest body)))))))\n\n;; letrec - mutually recursive local bindings\n;; All variables are visible to all init expressions.\n(define-syntax letrec\n (lambda (x)\n (syntax-case x ()\n ((letrec () body ...)\n (syntax (begin body ...)))\n ((letrec bindings body ...)\n (syntax (%letrec-names bindings bindings (begin body ...)))))))\n\n;; letrec* - sequential recursive local bindings \n;; Like letrec, but evaluates init expressions left-to-right.\n;; In our implementation, this is the same as letrec.\n(define-syntax letrec*\n (lambda (x)\n (syntax-case x ()\n ((letrec* () body ...)\n (syntax (begin body ...)))\n ((letrec* bindings body ...)\n (syntax (%letrec-names bindings bindings (begin body ...)))))))\n\n;; ============================================================\n;; Conditionals\n;; ============================================================\n\n;; and - logical AND, short-circuits on first #f\n(define-syntax and\n (syntax-rules ()\n ((and) #t)\n ((and test) test)\n ((and test rest ...)\n (if test (and rest ...) #f))))\n\n;; or - logical OR, short-circuits on first truthy value\n(define-syntax or\n (syntax-rules ()\n ((or) #f)\n ((or test) test)\n ((or test rest ...)\n (let ((temp test))\n (if temp temp (or rest ...))))))\n\n;; when - conditional execution when test is true\n(define-syntax when\n (syntax-rules ()\n ((when test body ...)\n (if test (begin body ...)))))\n\n;; unless - conditional execution when test is false\n(define-syntax unless\n (syntax-rules ()\n ((unless test body ...)\n (if (not test) (begin body ...)))))\n\n;; Simplified cond that doesn\'t use begin with ellipsis in results\n;; to avoid expansion issues\n(define-syntax cond\n (syntax-rules (else)\n ((cond (else result))\n result)\n ((cond (else result1 result2 ...))\n (begin result1 result2 ...))\n ((cond (test result))\n (if test result #f))\n ((cond (test result1 result2 ...))\n (if test (begin result1 result2 ...) #f))\n ((cond (test result) rest ...)\n (if test result (cond rest ...)))\n ((cond (test result1 result2 ...) rest ...)\n (if test (begin result1 result2 ...) (cond rest ...)))\n ((cond)\n #f)))\n\n;; ============================================================\n;; case - Pattern matching on values\n;; ============================================================\n\n;; case - match key against datum lists using eqv?\n;; Pattern: (case key ((datum ...) result ...) ... (else result ...))\n;; Simplified to 3 patterns for better maintainability\n(define-syntax case\n (syntax-rules (else)\n ((case key)\n (if #f #f))\n ((case key (else result ...))\n (begin result ...))\n ((case key ((datum ...) result ...) . rest)\n (if (memv key \'(datum ...))\n (begin result ...)\n (case key . rest)))))\n\n;; ============================================================\n;; do - Iteration construct\n;; ============================================================\n\n;; do uses a simpler recursive approach:\n;; 1. Extract bindings into (var init) pairs for named let\n;; 2. Extract step expressions for the recursive call\n;; \n;; Uses two helpers:\n;; %do-extract-vars - builds (var init) pairs\n;; %do-extract-steps - builds step expressions for recursive call\n\n;; Helper to extract var/init pairs for named let bindings\n;; Also collects step expressions\n(define-syntax %do-vars\n (lambda (x)\n (syntax-case x ()\n ;; Base case - no more bindings\n ((%do-vars () (pairs ...) (steps ...) test result body ...)\n (syntax (%do-run (pairs ...) (steps ...) test result body ...)))\n ;; Binding with step\n ((%do-vars ((var init step) . rest) (pairs ...) (steps ...) test result body ...)\n (syntax (%do-vars rest (pairs ... (var init)) (steps ... step) test result body ...)))\n ;; Binding without step (step = var)\n ((%do-vars ((var init) . rest) (pairs ...) (steps ...) test result body ...)\n (syntax (%do-vars rest (pairs ... (var init)) (steps ... var) test result body ...))))))\n\n;; Helper to run the do loop using named let\n(define-syntax %do-run\n (lambda (x)\n (syntax-case x ()\n ((%do-run (bindings ...) (steps ...) test (result ...) body ...)\n (syntax (let %do-loop (bindings ...)\n (if test\n (begin (if #f #f) result ...)\n (begin\n body ...\n (%do-loop steps ...)))))))))\n\n;; do - iteration with variable bindings\n;; Pattern: (do ((var init step) ...) (test result ...) body ...)\n(define-syntax do\n (lambda (x)\n (syntax-case x ()\n ((do bindings (test result ...) body ...)\n (syntax (%do-vars bindings () () test (result ...) body ...))))))\n\n;; ============================================================\n;; Variadic Append (R7RS compliant)\n;; ============================================================\n\n;; append - Concatenate any number of lists\n;; \n;; (append) => ()\n;; (append lst) => lst \n;; (append lst1 lst2) => concatenation of lst1 and lst2\n;; (append lst1 lst2 lst3 ...) => concatenation of all lists\n;;\n;; Implementation uses append-two from stdlib for the two-argument case,\n;; and recursively reduces longer argument lists.\n(define-syntax append\n (syntax-rules ()\n ((append) \'())\n ((append a) a)\n ((append a b) (append-two a b))\n ((append a b c ...)\n (append-two a (append b c ...)))))\n\n;; ============================================================\n;; Quasiquote\n;; ============================================================\n\n;; NOTE: Quasiquote is implemented as a built-in special form for performance.\n;;\n;; The special form uses trampolined evaluation which is highly optimized.\n;; Below is an alternative procedural macro implementation that demonstrates\n;; how quasiquote CAN be implemented using syntax-case with depth tracking.\n;;\n;; The macro uses Peano numerals to track nesting depth at expansion time:\n;; z = depth 0, (d z) = depth 1, (d (d z)) = depth 2, etc.\n;;\n;; This implementation is provided for educational purposes and to complete\n;; the procedural macro infrastructure. The special form remains the primary\n;; implementation due to its performance characteristics.\n\n;; Helper macro for quasiquote expansion with depth tracking\n;; Depth is tracked using Peano numerals: z=0, (d z)=1, (d (d z))=2, etc.\n(define-syntax %qq-expand\n (lambda (stx)\n (syntax-case stx (unquote unquote-splicing quasiquote d z)\n ;; At depth 1 (d z), unquote evaluates the expression\n ((_ (unquote e) (d z))\n (syntax e))\n ;; At depth > 1, unquote decrements depth and wraps result\n ((_ (unquote e) (d (d deeper)))\n (syntax (list \'unquote (%qq-expand e (d deeper)))))\n \n ;; Nested quasiquote - increment depth\n ((_ (quasiquote inner) depth)\n (syntax (list \'quasiquote (%qq-expand inner (d depth)))))\n \n ;; List where car is (unquote-splicing e) at depth 1 - use append\n ((_ ((unquote-splicing e) . rest) (d z))\n (syntax (append e (%qq-expand rest (d z)))))\n ;; List where car is (unquote-splicing e) at depth > 1 - keep structure\n ((_ ((unquote-splicing e) . rest) (d (d deeper)))\n (syntax (cons (list \'unquote-splicing (%qq-expand e (d deeper)))\n (%qq-expand rest (d (d deeper))))))\n \n ;; List where car is (unquote e) at depth 1 - evaluate and cons\n ((_ ((unquote e) . rest) (d z))\n (syntax (cons e (%qq-expand rest (d z)))))\n ;; List where car is (unquote e) at depth > 1 - keep structure\n ((_ ((unquote e) . rest) (d (d deeper)))\n (syntax (cons (list \'unquote (%qq-expand e (d deeper)))\n (%qq-expand rest (d (d deeper))))))\n \n ;; General list - recurse on both car and cdr\n ((_ (a . rest) depth)\n (syntax (cons (%qq-expand a depth) (%qq-expand rest depth))))\n ;; Empty list\n ((_ () depth)\n (syntax \'()))\n ;; Atom - quote it\n ((_ atom depth)\n (syntax \'atom)))))\n\n;; ============================================================\n;; Delayed Evaluation\n;; ============================================================\n\n;; delay - create a promise (memoizing thunk)\n(define-syntax delay\n (syntax-rules ()\n ((delay expr)\n (let ((forced #f)\n (value #f))\n (lambda ()\n (if forced\n value\n (begin\n (set! value expr)\n (set! forced #t)\n value)))))))\n\n;; ============================================================\n;; Multiple Values (R7RS Section 4.2.2 and 5.3.3)\n;; ============================================================\n\n;; let-values - bind multiple values from expressions\n;; \n;; (let-values (((a b) (values 1 2))\n;; ((c) (values 3)))\n;; (+ a b c))\n;; => 6\n;;\n;; Uses call-with-values to capture multiple values and bind them.\n;; Implementation note: We use a recursive approach to handle multiple bindings.\n(define-syntax let-values\n (syntax-rules ()\n ((let-values () body ...)\n (begin body ...))\n ((let-values ((formals init)) body ...)\n (call-with-values\n (lambda () init)\n (lambda formals body ...)))\n ((let-values ((formals init) rest ...) body ...)\n (call-with-values\n (lambda () init)\n (lambda formals\n (let-values (rest ...) body ...))))))\n\n;; let*-values - sequential binding of multiple values\n;;\n;; Like let-values, but bindings are visible to subsequent inits.\n;; Each binding\'s init can reference variables from previous bindings.\n;;\n;; (let*-values (((a b) (values 1 2))\n;; ((c) (values (+ a b))))\n;; c)\n;; => 3\n(define-syntax let*-values\n (syntax-rules ()\n ((let*-values () body ...)\n (begin body ...))\n ((let*-values ((formals init) rest ...) body ...)\n (call-with-values\n (lambda () init)\n (lambda formals\n (let*-values (rest ...) body ...))))))\n\n;; define-values - define multiple values at top level\n;;\n;; (define-values (x y) (values 1 2))\n;; x => 1\n;; y => 2\n;;\n;; Implementation: Uses R7RS spec approach with ellipsis patterns to handle\n;; arbitrary arity dynamically. This eliminates code duplication from the\n;; previous explicit arity-0 through arity-4 patterns.\n;;\n;; The implementation stores all values in a list, then extracts each variable\n;; by mutating the list structure. This allows the ellipsis pattern to handle\n;; any number of variables without explicit cases.\n(define-syntax define-values\n (lambda (x)\n (syntax-case x ()\n ;; Empty formals - just evaluate for side effects\n ((define-values () expr)\n (syntax (define %define-values-dummy\n (call-with-values (lambda () expr) (lambda args #f)))))\n ;; Single variable - extract using call-with-values\n ((define-values (var) expr)\n (syntax (define var (call-with-values (lambda () expr) (lambda (val) val)))))\n ;; Multiple variables (2 or more) - use ellipsis pattern for arbitrary arity\n ;; var0 holds the list initially, then each var1... extracts and mutates,\n ;; finally varn extracts the last value and sets var0 to its first element\n ((define-values (var0 var1 ... varn) expr)\n (syntax (begin\n (define var0\n (call-with-values (lambda () expr) list))\n (define var1\n (let ((v (cadr var0)))\n (set-cdr! var0 (cddr var0))\n v)) ...\n (define varn\n (let ((v (cadr var0)))\n (set! var0 (car var0))\n v)))))\n ;; Single identifier (not in a list) - capture all values as a list\n ((define-values var expr)\n (syntax (define var\n (call-with-values (lambda () expr) list)))))))\n\n;; force - force evaluation of a delayed expression\n(define-syntax force\n (syntax-rules ()\n ((force promise)\n (promise))))\n\n;; identifier-syntax - create macros that expand in identifier position (R6RS)\n;;\n;; (identifier-syntax e) creates a transformer that:\n;; - When referenced as a bare identifier, expands to e\n;; - When used in application position (id args ...), expands to (e args ...)\n;;\n;; Example:\n;; (let ((x 0))\n;; (define-syntax x++\n;; (identifier-syntax\n;; (let ((t x)) (set! x (+ t 1)) t)))\n;; (let ((a x++))\n;; (list a x))) => (0 1)\n(define-syntax identifier-syntax\n (lambda (x)\n (syntax-case x ()\n ((_ e)\n (syntax\n (lambda (x)\n (syntax-case x ()\n (id (identifier? (syntax id)) (syntax e))\n ((id rest (... ...)) (identifier? (syntax id)) (syntax (e rest (... ...)))))))))))\n\n;; ============================================================\n;; Case-Lambda (R7RS Section 4.2.9)\n;; ============================================================\n\n;; case-lambda - multiple-arity procedure dispatch\n;;\n;; Creates a procedure that dispatches based on the number of arguments.\n;; Each clause has the form (formals body ...) where formals is like lambda.\n;;\n;; Formals can be:\n;; - () - takes exactly 0 arguments\n;; - (x) - takes exactly 1 argument\n;; - (x y z) - takes exactly 3 arguments\n;; - (x . rest) - takes at least 1 argument, rest collected in a list\n;; - args - takes any number of arguments, all collected in a list\n;;\n;; Example:\n;; (define add\n;; (case-lambda\n;; (() 0)\n;; ((x) x)\n;; ((x y) (+ x y))\n;; (args (apply + args)))) ; catch-all for 3+ args\n;;\n;; (add) => 0\n;; (add 5) => 5\n;; (add 3 4) => 7\n;; (add 1 2 3) => 6\n\n;; Helper: Check if argument count n matches formals\n;; Returns #t if the clause can handle n arguments\n;; Proper list formals (x y z) require exact match\n;; Symbol formals or improper lists allow variable args\n(define-syntax %cl-arity-check\n (lambda (x)\n (syntax-case x ()\n ;; Exact arity matches for proper lists\n ((%cl-arity-check n ()) (syntax (= n 0)))\n ((%cl-arity-check n (a)) (syntax (= n 1)))\n ((%cl-arity-check n (a b)) (syntax (= n 2)))\n ((%cl-arity-check n (a b c)) (syntax (= n 3)))\n ((%cl-arity-check n (a b c d)) (syntax (= n 4)))\n ((%cl-arity-check n (a b c d e)) (syntax (= n 5)))\n ((%cl-arity-check n (a b c d e f)) (syntax (= n 6)))\n ((%cl-arity-check n (a b c d e f g)) (syntax (= n 7)))\n ((%cl-arity-check n (a b c d e f g h)) (syntax (= n 8)))\n ;; Catch-all: plain symbol (variadic) - matches any arity\n ;; This matches formals like `args` in `(lambda args ...)`\n ((%cl-arity-check n variadic) (syntax #t)))))\n\n;; Helper: Recursively build clause dispatch\n;; Tries each clause in order until one matches\n(define-syntax %cl-build\n (lambda (x)\n (syntax-case x ()\n ;; No more clauses - error\n ((%cl-build n args ())\n (syntax (error \"case-lambda: no matching clause for argument count\")))\n ;; Try first clause; if arity matches, apply it; otherwise try rest\n ((%cl-build n args ((formals body ...) . rest))\n (syntax (if (%cl-arity-check n formals)\n (apply (lambda formals body ...) args)\n (%cl-build n args rest)))))))\n\n;; Main case-lambda macro\n(define-syntax case-lambda\n (lambda (x)\n (syntax-case x ()\n ;; No clauses - error on any call\n ((case-lambda)\n (syntax (lambda args (error \"case-lambda: no clauses provided\"))))\n ;; Single clause - optimize to regular lambda\n ((case-lambda (formals body ...))\n (syntax (lambda formals body ...)))\n ;; Multiple clauses - dispatch based on argument count\n ((case-lambda clause ...)\n (syntax (lambda %args\n (let ((%n (length %args)))\n (%cl-build %n %args (clause ...)))))))))\n\n;; ============================================================\n;; Cond-Expand (R7RS Section 4.2.1)\n;; ============================================================\n\n;; cond-expand - feature-based conditional expansion\n;;\n;; Provides a way to statically expand different expressions depending\n;; on implementation features. Each clause has the form:\n;; (feature-requirement expression ...)\n;;\n;; Feature requirements can be:\n;; - feature-identifier: a symbol naming a feature\n;; - (library library-name): check if library is available\n;; - (and req ...): all requirements must be satisfied\n;; - (or req ...): at least one requirement must be satisfied\n;; - (not req): requirement must not be satisfied\n;; - else: always matches (must be last clause)\n;;\n;; Example:\n;; (cond-expand\n;; (grift (display \"Running on Grift\"))\n;; (else (display \"Unknown implementation\")))\n;;\n;; Supported feature identifiers for Grift:\n;; - r7rs: R7RS Scheme\n;; - grift: This implementation\n;; - exact-closed: Exact arithmetic is closed under common operations\n;; - ratios: Not supported (no rational numbers)\n;; - ieee-float: Not supported (no floating point)\n;;\n;; Implementation note: Since we don\'t have compile-time evaluation,\n;; we implement this with a set of known features. The feature check\n;; happens at macro expansion time through pattern matching.\n\n;; Check if a feature is supported\n;; Returns #t or #f at expansion time based on pattern matching\n;; Note: Uses syntax-case directly because it has many clauses (more than syntax-rules supports)\n(define-syntax %feature-check\n (lambda (x)\n (syntax-case x (and or not library r7rs grift exact-closed exact-complex ratios ieee-float)\n ;; Core features we support\n ((%feature-check r7rs) (syntax #t))\n ((%feature-check grift) (syntax #t))\n ((%feature-check exact-closed) (syntax #t))\n ;; Features we don\'t support\n ((%feature-check exact-complex) (syntax #f))\n ((%feature-check ratios) (syntax #f))\n ((%feature-check ieee-float) (syntax #f))\n ;; Compound requirements\n ((%feature-check (and)) (syntax #t))\n ((%feature-check (and req)) (syntax (%feature-check req)))\n ((%feature-check (and req1 req2 ...))\n (syntax (if (%feature-check req1)\n (%feature-check (and req2 ...))\n #f)))\n ((%feature-check (or)) (syntax #f))\n ((%feature-check (or req)) (syntax (%feature-check req)))\n ((%feature-check (or req1 req2 ...))\n (syntax (if (%feature-check req1)\n #t\n (%feature-check (or req2 ...)))))\n ((%feature-check (not req))\n (syntax (if (%feature-check req) #f #t)))\n ;; Library checks - we don\'t support any libraries yet\n ((%feature-check (library name)) (syntax #f))\n ;; Unknown feature\n ((%feature-check other) (syntax #f)))))\n\n;; Main cond-expand macro\n;; Note: Uses syntax-case to properly expand %feature-check at macro-expansion time\n(define-syntax cond-expand\n (lambda (x)\n (syntax-case x (else)\n ((cond-expand)\n (syntax (if #f #f)))\n ((cond-expand (else body ...))\n (syntax (begin body ...)))\n ((cond-expand (req body ...))\n (syntax (if (%feature-check req)\n (begin body ...)\n (if #f #f))))\n ((cond-expand (req body ...) rest ...)\n (syntax (if (%feature-check req)\n (begin body ...)\n (cond-expand rest ...)))))))\n\n;; ============================================================\n;; Lazy Evaluation Extensions (R7RS Section 4.2.5)\n;; ============================================================\n\n;; delay-force - Optimized lazy evaluation for iterative algorithms\n;;\n;; (delay-force expression) is conceptually similar to (delay (force expression)),\n;; but when forced, it results in a tail call to (force expression), preventing\n;; unbounded memory usage in iterative lazy algorithms.\n;;\n;; The key difference from (delay (force ...)) is that delay-force doesn\'t\n;; accumulate a chain of promises - it effectively replaces itself with\n;; the result of forcing the inner expression.\n;;\n;; Example: Stream filtering without space leak\n;; (define (stream-filter p? s)\n;; (delay-force\n;; (if (null? (force s))\n;; (delay \'())\n;; (let ((h (car (force s)))\n;; (t (cdr (force s))))\n;; (if (p? h)\n;; (delay (cons h (stream-filter p? t)))\n;; (stream-filter p? t))))))\n;;\n;; Implementation note: We implement delay-force by creating a promise that,\n;; when forced, evaluates its expression and if the result is itself a promise,\n;; forces that recursively. This achieves the tail-call-like behavior.\n(define-syntax delay-force\n (syntax-rules ()\n ((delay-force expr)\n (let ((forced #f)\n (value #f))\n (lambda ()\n (if forced\n value\n (let ((result expr))\n (let ((final-value (if (procedure? result)\n (result)\n result)))\n (set! value final-value)\n (set! forced #t)\n final-value))))))))\n\n;; ============================================================\n;; syntax-case Support (Phase 3)\n;; ============================================================\n\n;; with-syntax - bind pattern variables for use in syntax templates\n;;\n;; (with-syntax ((pattern expr) ...) body ...)\n;;\n;; Evaluates each expr and binds the result to the corresponding pattern.\n;; The bindings are available in the body expressions.\n;; This is implemented as a macro that uses syntax-case internally.\n;; NOTE: We use (begin ...) instead of (let () ...) to preserve\n;; pattern bindings in the current environment scope. Using let\n;; would create a new lambda whose environment doesn\'t include\n;; the #:pattern-bindings from the syntax-case context.\n(define-syntax with-syntax\n (lambda (x)\n (syntax-case x ()\n ;; No bindings: just evaluate the body\n ((_ () e1 e2 ...)\n (syntax (begin e1 e2 ...)))\n ;; Single binding: use syntax-case directly\n ((_ ((out in)) e1 e2 ...)\n (syntax (syntax-case in ()\n (out (begin e1 e2 ...)))))\n ;; Multiple bindings: use syntax-case with a list\n ((_ ((out in) ...) e1 e2 ...)\n (syntax (syntax-case (list in ...) ()\n ((out ...) (begin e1 e2 ...))))))))\n\n;; ============================================================\n;; Exception Handling (R7RS Section 4.2.7)\n;; ============================================================\n\n;; guard - Exception handling syntax (R7RS \u{a7}4.2.7)\n;;\n;; (guard (var cond-clause ...) body ...)\n;;\n;; Evaluates body with an exception handler. If an exception is raised,\n;; the exception is bound to var and the cond-clauses are evaluated.\n;; If no clause matches and there\'s no else clause, the exception is re-raised.\n;;\n;; Example:\n;; (guard (exn\n;; ((string? exn) exn)\n;; (else \"unknown error\"))\n;; (raise \"test error\"))\n\n;; Helper: Evaluate guard cond clauses (used when exception is caught)\n(define-syntax %guard-cond\n (syntax-rules (else)\n ((%guard-cond var (else result ...))\n (begin result ...))\n ((%guard-cond var (test result ...))\n (if test (begin result ...) (raise-continuable var)))\n ((%guard-cond var (test result ...) rest ...)\n (if test (begin result ...) (%guard-cond var rest ...)))))\n\n;; guard - full implementation using with-exception-handler\n(define-syntax guard\n (lambda (x)\n (syntax-case x ()\n ((guard (var clause ...) body ...)\n (syntax\n (with-exception-handler\n (lambda (var) (%guard-cond var clause ...))\n (lambda () body ...)))))))\n\n;; ============================================================\n;; Dynamic Parameters (R7RS Section 4.2.6)\n;; ============================================================\n\n;; parameterize - temporarily bind parameter values using dynamic-wind\n;;\n;; (parameterize ((param value) ...) body ...)\n;;\n;; Each param must be a parameter object created by make-parameter.\n;; The parameter is set to value for the dynamic extent of body,\n;; and restored afterwards (even if body raises an exception or\n;; invokes a continuation).\n(define-syntax parameterize\n (lambda (x)\n (syntax-case x ()\n ((parameterize () body ...)\n (syntax (begin body ...)))\n ((parameterize ((param value)) body ...)\n (syntax\n (let ((saved (param)))\n (dynamic-wind\n (lambda () (param value))\n (lambda () body ...)\n (lambda () (param saved))))))\n ((parameterize ((p1 v1) rest ...) body ...)\n (syntax\n (parameterize ((p1 v1))\n (parameterize (rest ...) body ...)))))))\n\n\n\n;;; ============================================================\n;;; Standard Library Function Definitions\n;;; ============================================================\n\n;;; Scheme Standard Library\n;;; \n;;; This file contains standard library function definitions.\n;;; It is processed by the include_stdlib! macro to generate the StdLib enum.\n;;;\n;;; Format:\n;;; ;;; Documentation comment\n;;; (define (function-name param1 param2 ...) body)\n\n;;; (map f lst) - Apply f to each element of lst (tail-recursive)\n(define (map f lst)\n (define (map-iter lst acc) ;; Helper function for tail-recursive iteration\n (if (null? lst)\n (reverse acc) ;; Base case: reverse accumulated list\n (map-iter (cdr lst) (cons (f (car lst)) acc)))) ;; Recursive case: apply f and continue\n (map-iter lst \'())) ;; Start with empty accumulator\n\n;;; (filter pred lst) - Return elements where pred is true (tail-recursive)\n(define (filter pred lst)\n (define (filter-iter lst acc) ;; Tail-recursive helper\n (if (null? lst)\n (reverse acc) ;; Base case\n (if (pred (car lst)) ;; Test if element matches predicate\n (filter-iter (cdr lst) (cons (car lst) acc)) ;; Include element\n (filter-iter (cdr lst) acc)))) ;; Skip element\n (filter-iter lst \'())) ;; Start with empty accumulator\n\n;;; (fold f acc lst) - Left fold over lst\n(define (fold f acc lst) ;; Left-associative fold\n (if (null? lst)\n acc ;; Base case: return accumulator\n (fold f (f acc (car lst)) (cdr lst)))) ;; Apply f to acc and car, recurse\n\n;;; (fold-left f acc lst) - Left fold over lst (R7RS name, same as fold)\n;;; f takes (accumulator, element) and returns new accumulator\n(define (fold-left f acc lst)\n (if (null? lst)\n acc\n (fold-left f (f acc (car lst)) (cdr lst))))\n\n;;; (length lst) - Return length of lst (tail-recursive)\n(define (length lst)\n (define (length-iter lst acc)\n (if (null? lst) acc (length-iter (cdr lst) (+ acc 1))))\n (length-iter lst 0))\n\n;;; (append-two a b) - Internal: Concatenate exactly two lists (tail-recursive)\n;;; This is the workhorse for the variadic append macro.\n(define (append-two a b)\n (define (rev-helper lst acc)\n (if (null? lst) acc (rev-helper (cdr lst) (cons (car lst) acc))))\n (define (append-iter lst acc)\n (if (null? lst) acc (append-iter (cdr lst) (cons (car lst) acc))))\n (append-iter (rev-helper a \'()) b))\n\n;;; (reverse lst) - Reverse a list\n(define (reverse lst) (fold (lambda (acc x) (cons x acc)) \'() lst))\n\n;;; (nth n lst) - Get nth element (0-indexed)\n;;; Validates that n is a non-negative integer.\n(define (nth n lst)\n (if (not (and (integer? n) (exact? n) (>= n 0)))\n (error \"nth: invalid index\" n)\n (nth-iter n lst n)))\n(define (nth-iter n lst original-n)\n (if (null? lst)\n (error \"nth: index out of range\" original-n)\n (if (= n 0) (car lst)\n (nth-iter (- n 1) (cdr lst) original-n))))\n\n;;; (take n lst) - Take first n elements\n;;; Validates that n is a non-negative integer.\n(define (take n lst)\n (if (not (and (integer? n) (exact? n) (>= n 0)))\n (error \"take: expected non-negative integer\" n)\n (take-iter n lst \'())))\n(define (take-iter n lst acc)\n (if (= n 0) (reverse acc)\n (if (null? lst) (reverse acc)\n (take-iter (- n 1) (cdr lst) (cons (car lst) acc)))))\n\n;;; (drop n lst) - Drop first n elements\n;;; Validates that n is a non-negative integer.\n(define (drop n lst)\n (if (not (and (integer? n) (exact? n) (>= n 0)))\n (error \"drop: expected non-negative integer\" n)\n (drop-iter n lst)))\n(define (drop-iter n lst)\n (if (= n 0) lst\n (if (null? lst) \'()\n (drop-iter (- n 1) (cdr lst)))))\n\n;;; (zip a b) - Zip two lists into list of pairs\n(define (zip a b) (if (null? a) \'() (if (null? b) \'() (cons (cons (car a) (car b)) (zip (cdr a) (cdr b))))))\n\n;;; ============================================================\n;;; Internal Helper Functions\n;;; ============================================================\n\n;;; (mem-helper pred obj lst) - Generic member helper using predicate\n(define (mem-helper pred obj lst) (if (null? lst) #f (if (pred obj (car lst)) lst (mem-helper pred obj (cdr lst)))))\n\n;;; (assoc-helper pred key alist) - Generic assoc helper using predicate\n(define (assoc-helper pred key alist) (if (null? alist) #f (if (pred key (car (car alist))) (car alist) (assoc-helper pred key (cdr alist)))))\n\n;;; ============================================================\n;;; Member and Assoc Functions (Using Helpers)\n;;; ============================================================\n\n;;; (member x lst) - Find x in lst using equal?, return sublist or #f\n(define (member x lst) (mem-helper equal? x lst))\n\n;;; (assoc key alist) - Look up key in association list using equal?\n(define (assoc key alist) (assoc-helper equal? key alist))\n\n;;; (range start end) - Generate list of integers [start, end) (tail-recursive)\n(define (range start end)\n (define (range-iter n acc)\n (if (< n start)\n acc\n (range-iter (- n 1) (cons n acc))))\n (range-iter (- end 1) \'()))\n\n;;; (compose f g) - Return function that applies g then f\n(define (compose f g) (lambda (x) (f (g x))))\n\n;;; (identity x) - Return x unchanged\n(define (identity x) x)\n\n;;; (constantly x) - Return function that always returns x\n(define (constantly x) (lambda (y) x))\n\n;;; (flip f) - Flip argument order of binary function\n(define (flip f) (lambda (a b) (f b a)))\n\n;;; (curry f x) - Partial application\n(define (curry f x) (lambda (y) (f x y)))\n\n;;; (cadr lst) - (car (cdr lst))\n(define (cadr lst) (car (cdr lst)))\n\n;;; (caddr lst) - (car (cdr (cdr lst)))\n(define (caddr lst) (car (cdr (cdr lst))))\n\n;;; (cddr lst) - (cdr (cdr lst))\n(define (cddr lst) (cdr (cdr lst)))\n\n;;; ============================================================\n;;; Phase 1: Core R7RS Procedures (Section 6.3-6.4)\n;;; ============================================================\n\n;;; (for-each f lst) - Apply f to each element for side effects\n;;; R7RS: The value returned is unspecified\n;;; We use (if #f #f) to produce an unspecified value (standard Scheme idiom)\n(define (for-each f lst) (if (null? lst) (if #f #f) (begin (f (car lst)) (for-each f (cdr lst)))))\n\n;;; (list-tail lst k) - Return sublist starting at k-th element\n;;; Validates that k is a valid non-negative index.\n(define (list-tail lst k)\n (if (not (and (integer? k) (exact? k) (>= k 0)))\n (error \"list-tail: invalid index\" k)\n (list-tail-iter lst k)))\n(define (list-tail-iter lst k)\n (if (= k 0) lst\n (if (null? lst)\n (error \"list-tail: index out of range\" k)\n (list-tail-iter (cdr lst) (- k 1)))))\n\n;;; (list-ref lst k) - Return k-th element of lst (0-indexed)\n;;; Validates that lst is a proper list and k is a non-negative integer.\n(define (list-ref lst k)\n (if (not (list? lst))\n (error \"list-ref: not a list\" lst)\n (if (not (and (integer? k) (exact? k) (>= k 0)))\n (error \"list-ref: invalid index\" k)\n (list-ref-iter lst k k))))\n(define (list-ref-iter lst k original-k)\n (if (null? lst)\n (error \"list-ref: index out of range\" original-k)\n (if (= k 0) (car lst)\n (list-ref-iter (cdr lst) (- k 1) original-k))))\n\n;;; (list? obj) - Check if obj is a proper list\n(define (list? obj) (if (null? obj) #t (if (pair? obj) (list? (cdr obj)) #f)))\n\n;;; (list-copy lst) - Create a shallow copy of a list\n(define (list-copy lst) (if (null? lst) \'() (cons (car lst) (list-copy (cdr lst)))))\n\n;;; (memq obj lst) - Find obj in lst using eq?, return sublist or #f\n(define (memq obj lst) (mem-helper eq? obj lst))\n\n;;; (memv obj lst) - Find obj in lst using eqv?, return sublist or #f\n(define (memv obj lst) (mem-helper eqv? obj lst))\n\n;;; (assq key alist) - Look up key in alist using eq?\n(define (assq key alist) (assoc-helper eq? key alist))\n\n;;; (assv key alist) - Look up key in alist using eqv?\n(define (assv key alist) (assoc-helper eqv? key alist))\n\n;;; ============================================================\n;;; Additional c...r accessors (R7RS Section 6.4)\n;;; ============================================================\n\n;;; (caar lst) - (car (car lst))\n(define (caar lst) (car (car lst)))\n\n;;; (cdar lst) - (cdr (car lst))\n(define (cdar lst) (cdr (car lst)))\n\n;;; (caaar lst) - (car (car (car lst)))\n(define (caaar lst) (car (car (car lst))))\n\n;;; (caadr lst) - (car (car (cdr lst)))\n(define (caadr lst) (car (car (cdr lst))))\n\n;;; (cadar lst) - (car (cdr (car lst)))\n(define (cadar lst) (car (cdr (car lst))))\n\n;;; (cdaar lst) - (cdr (car (car lst)))\n(define (cdaar lst) (cdr (car (car lst))))\n\n;;; (cdadr lst) - (cdr (car (cdr lst)))\n(define (cdadr lst) (cdr (car (cdr lst))))\n\n;;; (cddar lst) - (cdr (cdr (car lst)))\n(define (cddar lst) (cdr (cdr (car lst))))\n\n;;; (cdddr lst) - (cdr (cdr (cdr lst)))\n(define (cdddr lst) (cdr (cdr (cdr lst))))\n\n;;; (cadddr lst) - (car (cdr (cdr (cdr lst))))\n(define (cadddr lst) (car (cdr (cdr (cdr lst)))))\n\n;;; (cddddr lst) - (cdr (cdr (cdr (cdr lst))))\n(define (cddddr lst) (cdr (cdr (cdr (cdr lst)))))\n\n;;; ============================================================\n;;; Number utilities (R7RS Section 6.2.6)\n;;; ============================================================\n\n;;; (modulo a b) already builtin - use remainder-based modulo for stdlib\n;;; (sign n) - Return -1, 0, or 1 based on sign of n\n(define (sign n) (if (positive? n) 1 (if (negative? n) -1 0)))\n\n;;; (sqrt x) - Integer square root using Newton\'s method\n;;; Returns the largest integer whose square is <= x.\n;;; Raises an error if x is negative.\n(define (sqrt x)\n (if (not (and (integer? x) (exact? x)))\n (error \"sqrt: expected exact integer\" x)\n (if (negative? x)\n (error \"sqrt: negative argument\" x)\n (if (= x 0)\n 0\n (sqrt-iter x x)))))\n(define (sqrt-iter x guess)\n (let ((next (/ (+ guess (/ x guess)) 2)))\n (if (>= next guess)\n guess\n (sqrt-iter x next))))\n\n;;; (square x) - Return x squared\n(define (square x) (* x x))\n\n;;; (cube x) - Return x cubed\n(define (cube x) (* x x x))\n\n;;; (sum lst) - Sum all elements in a list\n(define (sum lst) (fold + 0 lst))\n\n;;; (product lst) - Product of all elements in a list\n(define (product lst) (fold * 1 lst))\n\n;;; (average lst) - Average of all elements in a list\n;;; Raises an error if the list is empty (division by zero).\n(define (average lst)\n (if (null? lst)\n (error \"average: empty list\")\n (/ (sum lst) (length lst))))\n\n;;; ============================================================\n;;; Additional R7RS List Functions (Section 6.4)\n;;; ============================================================\n\n;;; (make-list k fill) - Create a list of k elements, each initialized to fill.\n;;; Validates that k is a non-negative integer.\n(define (make-list k fill)\n (if (not (and (integer? k) (exact? k)))\n (error \"make-list: expected exact integer\" k)\n (if (< k 0)\n (error \"make-list: expected non-negative integer\" k)\n (make-list-iter k fill \'()))))\n(define (make-list-iter k fill acc)\n (if (<= k 0)\n acc\n (make-list-iter (- k 1) fill (cons fill acc))))\n\n;;; (list-set! lst k obj) - Store obj in element k of lst\n;;; Validates that k is a valid non-negative index.\n(define (list-set! lst k obj)\n (if (not (and (integer? k) (exact? k) (>= k 0)))\n (error \"list-set!: invalid index\" k)\n (set-car! (list-tail lst k) obj)))\n\n;;; (last-pair lst) - Return the last pair in a non-empty list\n;;; Raises an error if called on an empty list.\n(define (last-pair lst)\n (if (null? lst)\n (error \"last-pair: empty list\")\n (if (null? (cdr lst)) lst (last-pair (cdr lst)))))\n\n;;; (last lst) - Return the last element of a non-empty list\n;;; Raises an error if called on an empty list.\n(define (last lst)\n (if (null? lst)\n (error \"last: empty list\")\n (car (last-pair lst))))\n\n;;; ============================================================\n;;; R7RS member/assoc with equal? (Section 6.4)\n;;; ============================================================\n\n;;; (member-equal obj lst) - Find obj in lst using equal?, return sublist or #f\n(define (member-equal obj lst) (mem-helper equal? obj lst))\n\n;;; (assoc-equal key alist) - Look up key in alist using equal?\n(define (assoc-equal key alist) (assoc-helper equal? key alist))\n\n;;; ============================================================\n;;; Higher-order list functions (R7RS Section 6.10)\n;;; ============================================================\n\n;;; (reduce f init lst) - Right fold (foldr)\n(define (reduce f init lst) (if (null? lst) init (f (car lst) (reduce f init (cdr lst)))))\n\n;;; (fold-right f init lst) - Right fold, R7RS name\n(define (fold-right f init lst) (reduce f init lst))\n\n;;; (any pred lst) - Return #t if pred is true for any element\n(define (any pred lst) (if (null? lst) #f (if (pred (car lst)) #t (any pred (cdr lst)))))\n\n;;; (every pred lst) - Return #t if pred is true for all elements\n(define (every pred lst) (if (null? lst) #t (if (pred (car lst)) (every pred (cdr lst)) #f)))\n\n;;; (find pred lst) - Return first element where pred is true, or #f\n(define (find pred lst) (if (null? lst) #f (if (pred (car lst)) (car lst) (find pred (cdr lst)))))\n\n;;; (filter-map f lst) - Map f over lst, keeping only non-#f results (tail-recursive, no double calls)\n(define (filter-map f lst)\n (define (filter-map-iter lst acc)\n (if (null? lst)\n (reverse acc)\n (let ((result (f (car lst))))\n (if result\n (filter-map-iter (cdr lst) (cons result acc))\n (filter-map-iter (cdr lst) acc)))))\n (filter-map-iter lst \'()))\n\n;;; (partition pred lst) - Split lst into pair of two lists: (matching . non-matching)\n;;; Returns (cons matches non-matches) where matches contains elements satisfying pred.\n;;; Note: Uses tail-recursive helper to avoid let-binding issue in recursion.\n(define (partition pred lst) (partition-helper pred lst \'() \'()))\n(define (partition-helper pred lst matches non-matches) (if (null? lst) (cons (reverse matches) (reverse non-matches)) (if (pred (car lst)) (partition-helper pred (cdr lst) (cons (car lst) matches) non-matches) (partition-helper pred (cdr lst) matches (cons (car lst) non-matches)))))\n\n;;; (remove pred lst) - Return lst with elements where pred is true removed\n(define (remove pred lst) (filter (lambda (x) (not (pred x))) lst))\n\n;;; (delete x lst) - Remove all occurrences of x from lst using equal?\n(define (delete x lst) (filter (lambda (y) (not (equal? x y))) lst))\n\n;;; ============================================================\n;;; Boolean operations (R7RS Section 6.3)\n;;; ============================================================\n\n;;; (boolean-eq b1 b2) - Return #t if both arguments are #t or both are #f\n(define (boolean-eq b1 b2) (or (and b1 b2) (and (not b1) (not b2))))\n\n\n;;; ============================================================\n;;; Character Predicates (R7RS Section 6.6)\n;;; ============================================================\n\n;;; (char-alphabetic? char) - Check if char is alphabetic (a-z, A-Z)\n(define (char-alphabetic? c)\n (let ((n (char->integer c)))\n (or (and (>= n 65) (<= n 90))\n (and (>= n 97) (<= n 122)))))\n\n;;; (char-numeric? char) - Check if char is a decimal digit (0-9)\n(define (char-numeric? c)\n (let ((n (char->integer c)))\n (and (>= n 48) (<= n 57))))\n\n;;; (char-whitespace? char) - Check if char is whitespace\n(define (char-whitespace? c)\n (let ((n (char->integer c)))\n (or (= n 32) (= n 9) (= n 10) (= n 13) (= n 12))))\n\n;;; (char-upper-case? char) - Check if char is uppercase (A-Z)\n(define (char-upper-case? c)\n (let ((n (char->integer c)))\n (and (>= n 65) (<= n 90))))\n\n;;; (char-lower-case? char) - Check if char is lowercase (a-z)\n(define (char-lower-case? c)\n (let ((n (char->integer c)))\n (and (>= n 97) (<= n 122))))\n\n;;; (digit-value char) - Return numeric value (0-9) of a digit character, or #f\n(define (digit-value c)\n (let ((n (char->integer c)))\n (if (and (>= n 48) (<= n 57))\n (- n 48)\n #f)))\n\n;;; (char-foldcase char) - Unicode simple case-folding (lowercase for ASCII)\n(define (char-foldcase c)\n (char-downcase c))\n\n;;; Case-insensitive character comparisons\n\n;;; (char-ci=? char1 char2 ...) - Case-insensitive char=?\n(define (char-ci=? c1 c2)\n (char=? (char-foldcase c1) (char-foldcase c2)))\n\n;;; (char-ci<? char1 char2) - Case-insensitive char<?\n(define (char-ci<? c1 c2)\n (char<? (char-foldcase c1) (char-foldcase c2)))\n\n;;; (char-ci>? char1 char2) - Case-insensitive char>?\n(define (char-ci>? c1 c2)\n (char>? (char-foldcase c1) (char-foldcase c2)))\n\n;;; (char-ci<=? char1 char2) - Case-insensitive char<=?\n(define (char-ci<=? c1 c2)\n (char<=? (char-foldcase c1) (char-foldcase c2)))\n\n;;; (char-ci>=? char1 char2) - Case-insensitive char>=?\n(define (char-ci>=? c1 c2)\n (char>=? (char-foldcase c1) (char-foldcase c2)))\n\n;;; ============================================================\n;;; String Case-Insensitive Comparisons (R7RS Section 6.7)\n;;; ============================================================\n\n;;; (string-ci=? s1 s2) - Case-insensitive string=?\n;;; Note: For full implementation, would need to fold case of entire strings\n(define (string-ci=? s1 s2)\n (string-ci-compare-helper s1 s2 0 (string-length s1) (string-length s2)))\n\n(define (string-ci-compare-helper s1 s2 i len1 len2)\n (cond\n ((and (= i len1) (= i len2)) #t)\n ((= i len1) #f)\n ((= i len2) #f)\n ((char-ci=? (string-ref s1 i) (string-ref s2 i))\n (string-ci-compare-helper s1 s2 (+ i 1) len1 len2))\n (else #f)))\n\n;;; (string-upcase s) - Convert string to uppercase\n(define (string-upcase s)\n (list->string (map char-upcase (string->list s))))\n\n;;; (string-downcase s) - Convert string to lowercase\n(define (string-downcase s)\n (list->string (map char-downcase (string->list s))))\n\n;;; (string-foldcase s) - Convert string using case folding\n(define (string-foldcase s)\n (list->string (map char-foldcase (string->list s))))\n\n;;; ============================================================\n;;; Additional R7RS List Functions (SRFI-1 compatible)\n;;; ============================================================\n\n;;; (iota1 count) - Generate list of integers [0, count)\n(define (iota1 count)\n (iota-helper count 0 1 \'()))\n\n;;; (iota2 count start) - Generate list of integers [start, start+count)\n(define (iota2 count start)\n (iota-helper count start 1 \'()))\n\n;;; (iota3 count start step) - Generate arithmetic sequence\n(define (iota3 count start step)\n (iota-helper count start step \'()))\n\n(define (iota-helper count start step acc)\n (if (<= count 0)\n (reverse acc)\n (iota-helper (- count 1) (+ start step) step (cons start acc))))\n\n;;; (list-tabulate n proc) - Create list by applying proc to 0..n-1\n(define (list-tabulate n proc)\n (list-tabulate-helper n 0 proc \'()))\n\n(define (list-tabulate-helper n i proc acc)\n (if (>= i n)\n (reverse acc)\n (list-tabulate-helper n (+ i 1) proc (cons (proc i) acc))))\n\n;;; (circular-list x ...) - Create a circular list (infinite)\n;;; Note: This is dangerous - use carefully or not at all in finite memory\n\n;;; (first lst) - Return first element (alias for car)\n(define (first lst) (car lst))\n\n;;; (second lst) - Return second element\n(define (second lst) (cadr lst))\n\n;;; (third lst) - Return third element\n(define (third lst) (caddr lst))\n\n;;; (fourth lst) - Return fourth element\n(define (fourth lst) (cadddr lst))\n\n;;; (fifth lst) - Return fifth element\n(define (fifth lst) (car (cddddr lst)))\n\n;;; (sixth lst) - Return sixth element\n(define (sixth lst) (cadr (cddddr lst)))\n\n;;; (seventh lst) - Return seventh element\n(define (seventh lst) (caddr (cddddr lst)))\n\n;;; (eighth lst) - Return eighth element\n(define (eighth lst) (cadddr (cddddr lst)))\n\n;;; (ninth lst) - Return ninth element\n(define (ninth lst) (car (cddddr (cddddr lst))))\n\n;;; (tenth lst) - Return tenth element\n(define (tenth lst) (cadr (cddddr (cddddr lst))))\n\n;;; (take-right lst k) - Return the last k elements of lst\n;;; Uses lag-pointer technique: O(n) single traversal instead of O(n) for length + O(n) for drop\n(define (take-right lst k)\n (define (advance p count)\n (if (= count 0)\n p\n (if (null? p)\n \'()\n (advance (cdr p) (- count 1)))))\n (define (walk lead lag)\n (if (null? lead)\n lag\n (walk (cdr lead) (cdr lag))))\n (let ((lead (advance lst k)))\n (if (null? lead)\n lst\n (walk lead lst))))\n\n;;; (drop-right lst k) - Return all but the last k elements\n;;; Uses lag-pointer technique: O(n) single traversal, tail-recursive with accumulator\n(define (drop-right lst k)\n (define (advance p count)\n (if (= count 0)\n p\n (if (null? p)\n \'()\n (advance (cdr p) (- count 1)))))\n (define (walk lead lag acc)\n (if (null? lead)\n (reverse acc)\n (walk (cdr lead) (cdr lag) (cons (car lag) acc))))\n (let ((lead (advance lst k)))\n (if (null? lead)\n \'()\n (walk lead lst \'()))))\n\n;;; (split-at lst k) - Split list at position k, returns (take . drop)\n(define (split-at lst k)\n (cons (take k lst) (drop k lst)))\n\n;;; (concatenate lsts) - Append all lists in lsts\n(define (concatenate lsts)\n (fold-right append-two \'() lsts))\n\n;;; (flatten lst) - Flatten a nested list structure (O(n) tail-recursive)\n(define (flatten lst)\n (define (flatten-iter lst acc)\n (cond\n ((null? lst) acc)\n ((not (pair? lst)) (cons lst acc))\n (else (flatten-iter (car lst) (flatten-iter (cdr lst) acc)))))\n (flatten-iter lst \'()))\n\n;;; (count pred lst) - Count elements satisfying predicate\n(define (count pred lst)\n (fold (lambda (acc x) (if (pred x) (+ acc 1) acc)) 0 lst))\n\n;;; ============================================================\n;;; Additional String Functions\n;;; ============================================================\n\n;;; (string-for-each proc s) - Apply proc to each character for side effects\n(define (string-for-each proc s)\n (for-each proc (string->list s)))\n\n;;; (string-map proc s) - Map proc over characters, return new string\n(define (string-map proc s)\n (list->string (map proc (string->list s))))\n\n;;; (string-null? s) - Check if string is empty\n(define (string-null? s)\n (= (string-length s) 0))\n\n;;; (string-reverse s) - Reverse a string\n(define (string-reverse s)\n (list->string (reverse (string->list s))))\n\n;;; (string-contains s1 s2) - Check if s2 is a substring of s1\n;;; Returns index of first occurrence or #f\n(define (string-contains s1 s2)\n (let ((len1 (string-length s1))\n (len2 (string-length s2)))\n (if (> len2 len1)\n #f\n (string-contains-helper s1 s2 0 len1 len2))))\n\n(define (string-contains-helper s1 s2 i len1 len2)\n (if (> (+ i len2) len1)\n #f\n (if (string-prefix? s1 s2 i)\n i\n (string-contains-helper s1 s2 (+ i 1) len1 len2))))\n\n(define (string-prefix? s1 s2 start)\n (string-prefix-helper s1 s2 start 0 (string-length s2)))\n\n(define (string-prefix-helper s1 s2 i j len2)\n (if (>= j len2)\n #t\n (if (char=? (string-ref s1 i) (string-ref s2 j))\n (string-prefix-helper s1 s2 (+ i 1) (+ j 1) len2)\n #f)))\n\n;;; (string-join lst sep) - Join list of strings with separator\n(define (string-join lst sep)\n (if (null? lst)\n \"\"\n (fold (lambda (acc s) (string-append acc sep s))\n (car lst)\n (cdr lst))))\n\n;;; (string-split s sep) - Split string by separator character\n;;; Returns list of strings\n(define (string-split s sep)\n (string-split-helper (string->list s) sep \'() \'()))\n\n(define (string-split-helper chars sep current result)\n (cond\n ((null? chars)\n (reverse (cons (list->string (reverse current)) result)))\n ((char=? (car chars) sep)\n (string-split-helper (cdr chars) sep \'() \n (cons (list->string (reverse current)) result)))\n (else\n (string-split-helper (cdr chars) sep (cons (car chars) current) result))))\n\n;;; (string-trim s) - Remove leading and trailing whitespace\n(define (string-trim s)\n (list->string (reverse (drop-while-ws (reverse (drop-while-ws (string->list s)))))))\n\n(define (drop-while-ws lst)\n (cond\n ((null? lst) \'())\n ((char-whitespace? (car lst)) (drop-while-ws (cdr lst)))\n (else lst)))\n\n;;; ============================================================\n;;; Lazy Evaluation Functions (R7RS Section 4.2.5)\n;;; ============================================================\n\n;;; (promise? obj) - Check if obj is a promise\n;;; Note: In this implementation, promises are procedures (thunks).\n;;; This is consistent with R7RS which says \"promises are not necessarily\n;;; disjoint from other Scheme types such as procedures.\"\n(define (promise? obj)\n (procedure? obj))\n\n;;; (make-promise obj) - Create a promise that returns obj when forced\n;;; If obj is already a promise, it is returned unchanged.\n;;; This is a procedure, not syntax - it does not delay evaluation.\n(define (make-promise obj)\n (if (promise? obj)\n obj\n (lambda () obj)))\n\n;;; ============================================================\n;;; Dynamic Parameters (R7RS Section 4.2.6)\n;;; ============================================================\n\n;;; (make-parameter init) - Create a parameter object (R7RS \u{a7}4.2.6)\n;;; A parameter object is a procedure that:\n;;; - With no arguments, returns the current value\n;;; - With one argument, sets the value (via parameterize / internal use)\n(define (make-parameter init)\n (let ((value init))\n (lambda args\n (if (null? args)\n value\n (set! value (car args))))))\n\n";Expand description
The combined prelude source containing all macro and function definitions.
This is the raw content of prelude.scm, embedded at compile time.
The evaluator uses this to load standard macros at startup.