stdlib_data.h

// Auto-generated from stdlib.scm - do not edit
static const char stdlib_scm[] =
    "; R3RS Standard Library\n"
    "; This file is loaded automatically on startup\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Let forms as macros\n"
    ";;; ============================================================================\n"
    "\n"
    "; Note: letrec is built-in with proper call/cc semantics\n"
    "; (continuation restoration when reinvoking captured continuations)\n"
    "\n"
    "; let - parallel binding (named let uses built-in letrec)\n"
    "(define-syntax let\n"
    "  (syntax-rules ()\n"
    "    ((let ((var val) ...) body ...)\n"
    "     ((lambda (var ...) body ...) val ...))\n"
    "    ; Named let - evaluate inits in outer env, then bind name\n"
    "    ((let name ((var val) ...) body ...)\n"
    "     ((lambda (var ...)\n"
    "        (letrec ((name (lambda (var ...) body ...)))\n"
    "          (name var ...)))\n"
    "      val ...))))\n"
    "\n"
    "; let* - sequential binding (uses lambda directly)\n"
    "(define-syntax let*\n"
    "  (syntax-rules ()\n"
    "    ((let* () body ...)\n"
    "     (let () body ...))  ; Use let for proper scoping of internal defines\n"
    "    ((let* ((var val) . more-bindings) body ...)\n"
    "     ((lambda (var)\n"
    "        (let* more-bindings body ...))\n"
    "      val))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; MIT Scheme compatibility functions\n"
    ";;; ============================================================================\n"
    "\n"
    ";; string-search-forward: find first occurrence of pattern in text\n"
    ";; Returns index or #f\n"
    "(define (string-search-forward pattern text . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-search-forward: expected at most start and end\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length text)))\n"
    "        (plen (string-length pattern))\n"
    "        (tlen (string-length text)))\n"
    "    (if (= plen 0)\n"
    "        (error \"string-search-forward: pattern must be nonempty\")\n"
    "        (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end tlen))\n"
    "            (error \"string-search-forward: invalid search range\")\n"
    "            (let loop ((i start))\n"
    "              (cond ((> (+ i plen) end) #f)\n"
    "                    ((string=? pattern (substring text i (+ i plen))) i)\n"
    "                    (else (loop (+ i 1)))))))))\n"
    "\n"
    ";; string-search-backward: find last occurrence of pattern in text\n"
    "(define (string-search-backward pattern text . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-search-backward: expected at most start and end\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length text)))\n"
    "        (plen (string-length pattern))\n"
    "        (tlen (string-length text)))\n"
    "    (if (= plen 0)\n"
    "        (error \"string-search-backward: pattern must be nonempty\")\n"
    "        (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end tlen))\n"
    "            (error \"string-search-backward: invalid search range\")\n"
    "            (let loop ((i (- end plen)))\n"
    "              (cond ((< i start) #f)\n"
    "                    ((string=? pattern (substring text i (+ i plen)))\n"
    "                     i)\n"
    "                    (else (loop (- i 1)))))))))\n"
    "\n"
    "(define (string-search-all pattern text . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-search-all: expected at most start and end\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length text)))\n"
    "        (plen (string-length pattern))\n"
    "        (tlen (string-length text)))\n"
    "    (if (= plen 0)\n"
    "        (error \"string-search-all: pattern must be nonempty\")\n"
    "        (if (or (not (exact-nonnegative-integer? start))\n"
    "                (not (exact-nonnegative-integer? end))\n"
    "                (> start end)\n"
    "                (> end tlen))\n"
    "            (error \"string-search-all: invalid search range\")\n"
    "            (let loop ((i start) (result '()))\n"
    "              (if (> (+ i plen) end)\n"
    "                  (reverse result)\n"
    "                  (loop (+ i 1)\n"
    "                        (if (string=? pattern (substring text i (+ i plen)))\n"
    "                            (cons i result)\n"
    "                            result))))))))\n"
    "\n"
    "(define (substring? pattern text)\n"
    "  (if (= (string-length pattern) 0)\n"
    "      #t\n"
    "      (not (not (string-search-forward pattern text)))))\n"
    "\n"
    "(define (string-match-forward string1 string2)\n"
    "  (let ((limit (min (string-length string1) (string-length string2))))\n"
    "    (let loop ((i 0))\n"
    "      (if (and (< i limit)\n"
    "               (char=? (string-ref string1 i) (string-ref string2 i)))\n"
    "          (loop (+ i 1))\n"
    "          i))))\n"
    "\n"
    "(define (string-match-backward string1 string2)\n"
    "  (let ((len1 (string-length string1))\n"
    "        (len2 (string-length string2)))\n"
    "    (let loop ((i 0))\n"
    "      (if (and (< i len1)\n"
    "               (< i len2)\n"
    "               (char=? (string-ref string1 (- len1 i 1))\n"
    "                       (string-ref string2 (- len2 i 1))))\n"
    "          (loop (+ i 1))\n"
    "          i))))\n"
    "\n"
    "(define (string-find-next-char string char . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-find-next-char: expected at most start and end\"))\n"
    "  (if (not (char? char))\n"
    "      (error \"string-find-next-char: expected a character\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length string))))\n"
    "    (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end (string-length string)))\n"
    "        (error \"string-find-next-char: invalid search range\")\n"
    "        (let loop ((i start))\n"
    "          (cond ((>= i end) #f)\n"
    "                ((char=? (string-ref string i) char) i)\n"
    "                (else (loop (+ i 1))))))))\n"
    "\n"
    "(define (string-find-next-char-ci string char . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-find-next-char-ci: expected at most start and end\"))\n"
    "  (if (not (char? char))\n"
    "      (error \"string-find-next-char-ci: expected a character\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length string))))\n"
    "    (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end (string-length string)))\n"
    "        (error \"string-find-next-char-ci: invalid search range\")\n"
    "        (let loop ((i start))\n"
    "          (cond ((>= i end) #f)\n"
    "                ((char-ci=? (string-ref string i) char) i)\n"
    "                (else (loop (+ i 1))))))))\n"
    "\n"
    "(define (string-find-previous-char string char . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-find-previous-char: expected at most start and end\"))\n"
    "  (if (not (char? char))\n"
    "      (error \"string-find-previous-char: expected a character\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length string))))\n"
    "    (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end (string-length string)))\n"
    "        (error \"string-find-previous-char: invalid search range\")\n"
    "        (let loop ((i (- end 1)))\n"
    "          (cond ((< i start) #f)\n"
    "                ((char=? (string-ref string i) char) i)\n"
    "                (else (loop (- i 1))))))))\n"
    "\n"
    "(define (string-find-previous-char-ci string char . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-find-previous-char-ci: expected at most start and end\"))\n"
    "  (if (not (char? char))\n"
    "      (error \"string-find-previous-char-ci: expected a character\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length string))))\n"
    "    (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end (string-length string)))\n"
    "        (error \"string-find-previous-char-ci: invalid search range\")\n"
    "        (let loop ((i (- end 1)))\n"
    "          (cond ((< i start) #f)\n"
    "                ((char-ci=? (string-ref string i) char) i)\n"
    "                (else (loop (- i 1))))))))\n"
    "\n"
    "(define (string-find-next-char-in-set string set . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-find-next-char-in-set: expected at most start and end\"))\n"
    "  (%require-char-set \"string-find-next-char-in-set\" set)\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length string))))\n"
    "    (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end (string-length string)))\n"
    "        (error \"string-find-next-char-in-set: invalid search range\")\n"
    "        (let loop ((i start))\n"
    "          (cond ((>= i end) #f)\n"
    "                ((char-in-set? (string-ref string i) set) i)\n"
    "                (else (loop (+ i 1))))))))\n"
    "\n"
    "(define (string-find-previous-char-in-set string set . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-find-previous-char-in-set: expected at most start and end\"))\n"
    "  (%require-char-set \"string-find-previous-char-in-set\" set)\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (end (if (and (pair? args) (pair? (cdr args)))\n"
    "                 (cadr args)\n"
    "                 (string-length string))))\n"
    "    (if (or (not (exact-nonnegative-integer? start))\n"
    "            (not (exact-nonnegative-integer? end))\n"
    "            (> start end)\n"
    "            (> end (string-length string)))\n"
    "        (error \"string-find-previous-char-in-set: invalid search range\")\n"
    "        (let loop ((i (- end 1)))\n"
    "          (cond ((< i start) #f)\n"
    "                ((char-in-set? (string-ref string i) set) i)\n"
    "                (else (loop (- i 1))))))))\n"
    "\n"
    "(define (%string-predicate-search who string predicate start end reverse? skip?)\n"
    "  (if (not (procedure? predicate))\n"
    "      (error (string-append who \": expected a predicate\")))\n"
    "  (if (or (not (exact-nonnegative-integer? start))\n"
    "          (not (exact-nonnegative-integer? end))\n"
    "          (> start end)\n"
    "          (> end (string-length string)))\n"
    "      (error (string-append who \": invalid search range\")))\n"
    "  (let ((matches? (lambda (index)\n"
    "                    (let ((result (predicate (string-ref string index))))\n"
    "                      (if skip? (not result) result)))))\n"
    "    (if reverse?\n"
    "        (let loop ((index (- end 1)))\n"
    "          (cond ((< index start) #f)\n"
    "                ((matches? index) index)\n"
    "                (else (loop (- index 1)))))\n"
    "        (let loop ((index start))\n"
    "          (cond ((>= index end) #f)\n"
    "                ((matches? index) index)\n"
    "                (else (loop (+ index 1))))))))\n"
    "\n"
    "(define (string-index string predicate . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-index: expected at most start and end\"))\n"
    "  (%string-predicate-search\n"
    "   \"string-index\" string predicate\n"
    "   (if (pair? args) (car args) 0)\n"
    "   (if (and (pair? args) (pair? (cdr args)))\n"
    "       (cadr args)\n"
    "       (string-length string))\n"
    "   #f #f))\n"
    "\n"
    "(define (string-index-right string predicate . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-index-right: expected at most start and end\"))\n"
    "  (%string-predicate-search\n"
    "   \"string-index-right\" string predicate\n"
    "   (if (pair? args) (car args) 0)\n"
    "   (if (and (pair? args) (pair? (cdr args)))\n"
    "       (cadr args)\n"
    "       (string-length string))\n"
    "   #t #f))\n"
    "\n"
    "(define (string-skip string predicate . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-skip: expected at most start and end\"))\n"
    "  (%string-predicate-search\n"
    "   \"string-skip\" string predicate\n"
    "   (if (pair? args) (car args) 0)\n"
    "   (if (and (pair? args) (pair? (cdr args)))\n"
    "       (cadr args)\n"
    "       (string-length string))\n"
    "   #f #t))\n"
    "\n"
    "(define (string-skip-right string predicate . args)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"string-skip-right: expected at most start and end\"))\n"
    "  (%string-predicate-search\n"
    "   \"string-skip-right\" string predicate\n"
    "   (if (pair? args) (car args) 0)\n"
    "   (if (and (pair? args) (pair? (cdr args)))\n"
    "       (cadr args)\n"
    "       (string-length string))\n"
    "   #t #t))\n"
    "\n"
    "(define (string-take string count)\n"
    "  (%require-nonnegative-integer \"string-take\" count)\n"
    "  (if (> count (string-length string))\n"
    "      (error \"string-take: count exceeds string length\"))\n"
    "  (substring string 0 count))\n"
    "\n"
    "(define (string-drop string count)\n"
    "  (%require-nonnegative-integer \"string-drop\" count)\n"
    "  (if (> count (string-length string))\n"
    "      (error \"string-drop: count exceeds string length\"))\n"
    "  (substring string count))\n"
    "\n"
    "(define (string-take-right string count)\n"
    "  (%require-nonnegative-integer \"string-take-right\" count)\n"
    "  (let ((length (string-length string)))\n"
    "    (if (> count length)\n"
    "        (error \"string-take-right: count exceeds string length\"))\n"
    "    (substring string (- length count) length)))\n"
    "\n"
    "(define (string-drop-right string count)\n"
    "  (%require-nonnegative-integer \"string-drop-right\" count)\n"
    "  (let ((length (string-length string)))\n"
    "    (if (> count length)\n"
    "        (error \"string-drop-right: count exceeds string length\"))\n"
    "    (substring string 0 (- length count))))\n"
    "\n"
    "(define (%string-contains-range who string start end)\n"
    "  (if (or (not (exact-nonnegative-integer? start))\n"
    "          (not (exact-nonnegative-integer? end))\n"
    "          (> start end)\n"
    "          (> end (string-length string)))\n"
    "      (error (string-append who \": invalid string range\")))\n"
    "  #t)\n"
    "\n"
    "(define (%string-contains-args who string1 string2 args)\n"
    "  (if (not (or (= (length args) 0)\n"
    "               (= (length args) 2)\n"
    "               (= (length args) 4)))\n"
    "      (error (string-append who \": expected zero, two, or four range arguments\")))\n"
    "  (let ((start1 (if (pair? args) (car args) 0))\n"
    "        (end1 (if (pair? args)\n"
    "                  (if (pair? (cdr args)) (cadr args) 0)\n"
    "                  (string-length string1)))\n"
    "        (start2 (if (and (pair? args) (pair? (cdr args)))\n"
    "                    (if (pair? (cddr args)) (caddr args) 0)\n"
    "                    0))\n"
    "        (end2 (if (and (pair? args) (pair? (cdr args)))\n"
    "                  (if (pair? (cddr args))\n"
    "                      (if (pair? (cdddr args)) (cadddr args) 0)\n"
    "                      (string-length string2))\n"
    "                  (string-length string2))))\n"
    "    (%string-contains-range who string1 start1 end1)\n"
    "    (%string-contains-range who string2 start2 end2)\n"
    "    (list start1 end1 start2 end2)))\n"
    "\n"
    "(define (string-contains string1 string2 . args)\n"
    "  (let* ((ranges (%string-contains-args \"string-contains\" string1 string2 args))\n"
    "         (start1 (car ranges))\n"
    "         (end1 (cadr ranges))\n"
    "         (start2 (caddr ranges))\n"
    "         (end2 (cadddr ranges))\n"
    "         (needle (substring string2 start2 end2)))\n"
    "    (if (= start2 end2)\n"
    "        start1\n"
    "        (let ((found (string-search-forward\n"
    "                      needle (substring string1 start1 end1))))\n"
    "          (if found (+ start1 found) #f)))))\n"
    "\n"
    "(define (string-contains-right string1 string2 . args)\n"
    "  (let* ((ranges (%string-contains-args \"string-contains-right\" string1 string2 args))\n"
    "         (start1 (car ranges))\n"
    "         (end1 (cadr ranges))\n"
    "         (start2 (caddr ranges))\n"
    "         (end2 (cadddr ranges))\n"
    "         (needle (substring string2 start2 end2)))\n"
    "    (if (= start2 end2)\n"
    "        end1\n"
    "        (let ((found (string-search-backward\n"
    "                      needle (substring string1 start1 end1))))\n"
    "          (if found (+ start1 found) #f)))))\n"
    "\n"
    "(define (string-find-first-index proc string . strings)\n"
    "  (let ((all (cons string strings)))\n"
    "    (let loop ((i 0))\n"
    "      (if (or (null? all)\n"
    "              (any (lambda (s) (>= i (string-length s))) all))\n"
    "          #f\n"
    "          (if (apply proc (map (lambda (s) (string-ref s i)) all))\n"
    "              i\n"
    "              (loop (+ i 1)))))))\n"
    "\n"
    "(define (string-find-last-index proc string . strings)\n"
    "  (let* ((all (cons string strings))\n"
    "         (limit (apply min (map string-length all))))\n"
    "    (let loop ((i (- limit 1)))\n"
    "      (if (< i 0)\n"
    "          #f\n"
    "          (if (apply proc (map (lambda (s) (string-ref s i)) all))\n"
    "              i\n"
    "              (loop (- i 1)))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Bitwise helpers (MIT Scheme compatibility)\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (%require-bit-index who bit-num)\n"
    "  (if (not (and (integer? bit-num)\n"
    "                (exact? bit-num)\n"
    "                (>= bit-num 0)))\n"
    "      (error (string-append who\n"
    "                            \": expected a non-negative exact integer bit position\")))\n"
    "  bit-num)\n"
    "\n"
    "(define (%require-bit-integer who value)\n"
    "  (if (not (and (integer? value) (exact? value)))\n"
    "      (error (string-append who \": expected an exact integer\")))\n"
    "  value)\n"
    "\n"
    "(define (bit bit-num)\n"
    "  (arithmetic-shift 1 (%require-bit-index \"bit\" bit-num)))\n"
    "\n"
    "(define (bits first-bit last-bit)\n"
    "  (let* ((first (%require-bit-index \"bits\" first-bit))\n"
    "         (last (%require-bit-index \"bits\" last-bit))\n"
    "         (low (min first last))\n"
    "         (high (max first last)))\n"
    "    (arithmetic-shift (- (arithmetic-shift 1 (+ (- high low) 1)) 1)\n"
    "                      low)))\n"
    "\n"
    "(define (set-bit bit-num value)\n"
    "  (bitwise-ior (%require-bit-integer \"set-bit\" value)\n"
    "               (bit bit-num)))\n"
    "\n"
    "(define (clear-bit bit-num value)\n"
    "  (bitwise-and (%require-bit-integer \"clear-bit\" value)\n"
    "               (bitwise-not (bit bit-num))))\n"
    "\n"
    "(define (toggle-bit bit-num value)\n"
    "  (bitwise-xor (%require-bit-integer \"toggle-bit\" value)\n"
    "               (bit bit-num)))\n"
    "\n"
    "(define (bit-set? bit-num val)\n"
    "  (not (= 0 (bitwise-and (%require-bit-integer \"bit-set?\" val)\n"
    "                         (bit bit-num)))))\n"
    "\n"
    "(define (extract-bit bit-num value)\n"
    "  (if (bit-set? bit-num (%require-bit-integer \"extract-bit\" value)) 1 0))\n"
    "\n"
    "(define (bit-clear? bit-num value)\n"
    "  (not (bit-set? bit-num (%require-bit-integer \"bit-clear?\" value))))\n"
    "\n"
    "(define (first-set-bit value)\n"
    "  (let ((value (%require-bit-integer \"first-set-bit\" value)))\n"
    "    (if (= value 0)\n"
    "        -1\n"
    "        (let loop ((bit-num 0))\n"
    "          (if (bit-set? bit-num value)\n"
    "              bit-num\n"
    "              (loop (+ bit-num 1)))))))\n"
    "\n"
    "(define (integer-length value)\n"
    "  (let ((value (%require-bit-integer \"integer-length\" value)))\n"
    "    (let loop ((value (if (< value 0) (bitwise-not value) value))\n"
    "               (length 0))\n"
    "      (if (= value 0)\n"
    "          length\n"
    "          (loop (arithmetic-shift value -1) (+ length 1))))))\n"
    "\n"
    "(define (bitwise-andc1 first second)\n"
    "  (bitwise-and (bitwise-not (%require-bit-integer \"bitwise-andc1\" first))\n"
    "               (%require-bit-integer \"bitwise-andc1\" second)))\n"
    "\n"
    "(define (bitwise-andc2 first second)\n"
    "  (bitwise-and (%require-bit-integer \"bitwise-andc2\" first)\n"
    "               (bitwise-not (%require-bit-integer \"bitwise-andc2\" second))))\n"
    "\n"
    "(define (bitwise-orc1 first second)\n"
    "  (bitwise-ior (bitwise-not (%require-bit-integer \"bitwise-orc1\" first))\n"
    "               (%require-bit-integer \"bitwise-orc1\" second)))\n"
    "\n"
    "(define (bitwise-orc2 first second)\n"
    "  (bitwise-ior (%require-bit-integer \"bitwise-orc2\" first)\n"
    "               (bitwise-not (%require-bit-integer \"bitwise-orc2\" second))))\n"
    "\n"
    "(define (bitwise-nand first second)\n"
    "  (bitwise-not\n"
    "   (bitwise-and (%require-bit-integer \"bitwise-nand\" first)\n"
    "                (%require-bit-integer \"bitwise-nand\" second))))\n"
    "\n"
    "(define (bitwise-nor first second)\n"
    "  (bitwise-not\n"
    "   (bitwise-ior (%require-bit-integer \"bitwise-nor\" first)\n"
    "                (%require-bit-integer \"bitwise-nor\" second))))\n"
    "\n"
    "(define (bitwise-eqv . values)\n"
    "  (if (null? values)\n"
    "      -1\n"
    "      (bitwise-not (apply bitwise-xor\n"
    "                         (map (lambda (value)\n"
    "                                (%require-bit-integer \"bitwise-eqv\" value))\n"
    "                              values)))))\n"
    "\n"
    "(define (shift-left value amount)\n"
    "  (arithmetic-shift (%require-bit-integer \"shift-left\" value)\n"
    "                    (%require-bit-index \"shift-left\" amount)))\n"
    "\n"
    "(define (shift-right value amount)\n"
    "  (arithmetic-shift (%require-bit-integer \"shift-right\" value)\n"
    "                    (- (%require-bit-index \"shift-right\" amount))))\n"
    "\n"
    "(define (bit-mask size position)\n"
    "  (let ((size (%require-bit-index \"bit-mask\" size))\n"
    "        (position (%require-bit-index \"bit-mask\" position)))\n"
    "    (if (= size 0)\n"
    "        0\n"
    "        (arithmetic-shift (- (arithmetic-shift 1 size) 1) position))))\n"
    "\n"
    "(define (bit-antimask size position)\n"
    "  (bitwise-not (bit-mask size position)))\n"
    "\n"
    ";; MIT Scheme compatibility aliases\n"
    "(define random random-integer)\n"
    "\n"
    ";; R7RS binary I/O\n"
    "(define (write-u8 byte . opt-port)\n"
    "  (if (> (length opt-port) 1)\n"
    "      (error \"write-u8: expected at most one port\"))\n"
    "  (if (or (not (exact-integer? byte)) (< byte 0) (> byte 255))\n"
    "      (error \"write-u8: expected an integer in the range 0 to 255\"))\n"
    "  (let ((port (if (pair? opt-port) (car opt-port) (current-output-port))))\n"
    "    (cond\n"
    "      ((bytevector-output-port-open? port)\n"
    "       (vector-set! port 1 (cons (bytevector byte) (vector-ref port 1))))\n"
    "      ((bytevector-output-port? port)\n"
    "       (error \"write-u8: port is closed\"))\n"
    "      ((binary-port? port)\n"
    "       (write-bytevector (bytevector byte) port))\n"
    "      (else\n"
    "       (error \"write-u8: not a binary output port\")))))\n"
    "\n"
    "(define (read-u8 . opt-port)\n"
    "  (if (> (length opt-port) 1)\n"
    "      (error \"read-u8: expected at most one port\"))\n"
    "  (let ((port (if (pair? opt-port) (car opt-port) (current-input-port))))\n"
    "    (cond\n"
    "      ((bytevector-input-port-open? port)\n"
    "       (let* ((bv (vector-ref port 1))\n"
    "              (state (vector-ref port 2))\n"
    "              (pos (car state))\n"
    "              (end (cdr state)))\n"
    "         (if (>= pos end)\n"
    "             (eof-object)\n"
    "             (begin\n"
    "               (vector-set! port 2 (cons (+ pos 1) end))\n"
    "               (bytevector-u8-ref bv pos)))))\n"
    "      ((bytevector-input-port? port)\n"
    "       (error \"read-u8: port is closed\"))\n"
    "      ((binary-port? port)\n"
    "       (let ((bv (read-bytevector 1 port)))\n"
    "         (if (eof-object? bv)\n"
    "             bv\n"
    "             (bytevector-u8-ref bv 0))))\n"
    "      (else\n"
    "       (error \"read-u8: not a binary input port\")))))\n"
    "\n"
    ";; The C text-output primitives understand file and string ports.  Bytevector\n"
    ";; ports are represented here as vectors, so route implicit and explicit\n"
    ";; bytevector output through the binary wrappers after rendering objects into\n"
    ";; a temporary string port.\n"
    "(let ((primitive-display display)\n"
    "      (primitive-write write)\n"
    "      (primitive-write-shared write-shared)\n"
    "      (primitive-write-simple write-simple)\n"
    "      (primitive-write-char write-char)\n"
    "      (primitive-newline newline))\n"
    "  (define (write-text-to-bytevector-port string port)\n"
    "    (let ((bytes (string->utf8 string)))\n"
    "      (let loop ((index 0))\n"
    "        (if (< index (bytevector-length bytes))\n"
    "            (begin\n"
    "              (write-u8 (bytevector-u8-ref bytes index) port)\n"
    "              (loop (+ index 1)))))))\n"
    "  (define (render-object-to-bytevector-port writer object port)\n"
    "    (let ((temporary (open-output-string)))\n"
    "      (writer object temporary)\n"
    "      (write-text-to-bytevector-port (get-output-string temporary) port)))\n"
    "  (set! display\n"
    "    (lambda (object . opt-port)\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"display: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-output-port))))\n"
    "        (if (bytevector-output-port? port)\n"
    "            (render-object-to-bytevector-port primitive-display object port)\n"
    "            (apply primitive-display (cons object opt-port))))))\n"
    "  (set! write\n"
    "    (lambda (object . opt-port)\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"write: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-output-port))))\n"
    "        (if (bytevector-output-port? port)\n"
    "            (render-object-to-bytevector-port primitive-write object port)\n"
    "            (apply primitive-write (cons object opt-port))))))\n"
    "  (set! write-shared\n"
    "    (lambda (object . opt-port)\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"write-shared: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-output-port))))\n"
    "        (if (bytevector-output-port? port)\n"
    "            (render-object-to-bytevector-port primitive-write-shared object port)\n"
    "            (apply primitive-write-shared (cons object opt-port))))))\n"
    "  (set! write-simple\n"
    "    (lambda (object . opt-port)\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"write-simple: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-output-port))))\n"
    "        (if (bytevector-output-port? port)\n"
    "            (render-object-to-bytevector-port primitive-write-simple object port)\n"
    "            (apply primitive-write-simple (cons object opt-port))))))\n"
    "  (set! write-char\n"
    "    (lambda (char . opt-port)\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"write-char: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-output-port))))\n"
    "        (if (bytevector-output-port? port)\n"
    "            (write-text-to-bytevector-port (string char) port)\n"
    "            (apply primitive-write-char (cons char opt-port))))))\n"
    "  (set! newline\n"
    "    (lambda opt-port\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"newline: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-output-port))))\n"
    "        (if (bytevector-output-port? port)\n"
    "            (write-u8 10 port)\n"
    "            (apply primitive-newline opt-port))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Binary I/O helpers\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (call-with-binary-input-file filename proc)\n"
    "  (let ((port (open-binary-input-file filename)))\n"
    "    (call-with-port port proc)))\n"
    "\n"
    "(define (call-with-binary-output-file filename proc)\n"
    "  (let ((port (open-binary-output-file filename)))\n"
    "    (call-with-port port proc)))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Bytevector ports (in-memory I/O using bytevectors)\n"
    ";;; ============================================================================\n"
    "\n"
    ";; Bytevector output port: vector #(tag chunks)\n"
    "(define (open-output-bytevector)\n"
    "  (vector 'bvout '()))\n"
    "\n"
    "(define (bytevector-chunks? chunks)\n"
    "  (and (list? chunks)\n"
    "       (let loop ((xs chunks))\n"
    "         (if (null? xs)\n"
    "             #t\n"
    "             (and (bytevector? (car xs))\n"
    "                  (loop (cdr xs)))))))\n"
    "\n"
    "(define (bytevector-output-port? x)\n"
    "  (and (vector? x) (= (vector-length x) 2)\n"
    "       (or (eq? (vector-ref x 0) 'bvout)\n"
    "           (eq? (vector-ref x 0) 'bvout-closed))\n"
    "       (bytevector-chunks? (vector-ref x 1))))\n"
    "\n"
    "(define (bytevector-output-port-open? x)\n"
    "  (and (bytevector-output-port? x) (eq? (vector-ref x 0) 'bvout)))\n"
    "\n"
    "(define (get-output-bytevector port)\n"
    "  (if (bytevector-output-port? port)\n"
    "      (apply bytevector-append (reverse (vector-ref port 1)))\n"
    "      (error \"get-output-bytevector: not an output bytevector port\")))\n"
    "\n"
    ";; Bytevector input port: vector #(tag bv (position . end)).  Keep the\n"
    ";; original bytevector, as MIT's bytevector input ports observe mutations to\n"
    ";; the source after the port is opened.  The pair stores the half-open range\n"
    ";; without requiring a copied slice.\n"
    "(define (open-input-bytevector bv . args)\n"
    "  (if (not (bytevector? bv))\n"
    "      (error \"open-input-bytevector: expected a bytevector\"))\n"
    "  (if (> (length args) 2)\n"
    "      (error \"open-input-bytevector: too many arguments\"))\n"
    "  (let* ((start (if (pair? args) (car args) 0))\n"
    "         (rest (if (pair? args) (cdr args) '()))\n"
    "         (end (if (pair? rest)\n"
    "                  (car rest)\n"
    "                  (bytevector-length bv))))\n"
    "    (%require-nonnegative-integer \"open-input-bytevector\" start)\n"
    "    (%require-nonnegative-integer \"open-input-bytevector\" end)\n"
    "    (if (or (> start end) (> end (bytevector-length bv)))\n"
    "        (error \"open-input-bytevector: invalid bytevector range\"))\n"
    "    (vector 'bvin bv (cons start end))))\n"
    "\n"
    "(define (call-with-output-bytevector proc)\n"
    "  (let ((port (open-output-bytevector)))\n"
    "    (proc port)\n"
    "    (get-output-bytevector port)))\n"
    "\n"
    "(define (bytevector-input-port? x)\n"
    "  (and (vector? x) (= (vector-length x) 3)\n"
    "       (or (eq? (vector-ref x 0) 'bvin)\n"
    "           (eq? (vector-ref x 0) 'bvin-closed))\n"
    "       (bytevector? (vector-ref x 1))\n"
    "       (pair? (vector-ref x 2))\n"
    "       (exact-nonnegative-integer? (car (vector-ref x 2)))\n"
    "       (exact-nonnegative-integer? (cdr (vector-ref x 2)))\n"
    "       (<= (car (vector-ref x 2))\n"
    "           (cdr (vector-ref x 2)))\n"
    "       (<= (cdr (vector-ref x 2))\n"
    "           (bytevector-length (vector-ref x 1)))))\n"
    "\n"
    "(define (bytevector-input-port-open? x)\n"
    "  (and (bytevector-input-port? x) (eq? (vector-ref x 0) 'bvin)))\n"
    "\n"
    ";; write-bytevector: write all or part of a bytevector to a port\n"
    "(define primitive-write-bytevector write-bytevector)\n"
    "\n"
    "(define (write-bytevector bv . args)\n"
    "  (if (> (length args) 3)\n"
    "      (error \"write-bytevector: too many arguments\"))\n"
    "  (let* ((port (if (pair? args) (car args) (current-output-port)))\n"
    "         (rest (if (pair? args) (cdr args) '()))\n"
    "         (start (if (pair? rest) (car rest) 0))\n"
    "         (rest2 (if (pair? rest) (cdr rest) '()))\n"
    "         (end (if (pair? rest2) (car rest2) (bytevector-length bv))))\n"
    "    (cond\n"
    "      ((bytevector-output-port-open? port)\n"
    "       (vector-set! port 1 (cons (bytevector-copy bv start end) (vector-ref port 1))))\n"
    "      ((bytevector-output-port? port)\n"
    "       (error \"write-bytevector: port is closed\"))\n"
    "      (else\n"
    "       (primitive-write-bytevector (bytevector-copy bv start end) port)))))\n"
    "\n"
    ";; Wrap read-bytevector to support bytevector input ports\n"
    "(let ((prim-read-bytevector read-bytevector))\n"
    "  (set! read-bytevector\n"
    "    (lambda (k . args)\n"
    "     (%require-nonnegative-integer \"read-bytevector\" k)\n"
    "     (if (> (length args) 1)\n"
    "         (error \"read-bytevector: too many arguments\"))\n"
    "     (let ((port (if (pair? args) (car args) (current-input-port))))\n"
    "      (cond\n"
    "        ((bytevector-input-port-open? port)\n"
    "         (let* ((bv (vector-ref port 1))\n"
    "                (state (vector-ref port 2))\n"
    "                (pos (car state))\n"
    "                (end (cdr state))\n"
    "                (available (- end pos)))\n"
    "           (if (= k 0)\n"
    "               (bytevector)\n"
    "               (if (<= available 0)\n"
    "               (eof-object)\n"
    "               (let* ((n (min k available))\n"
    "                      (result (bytevector-copy bv pos (+ pos n))))\n"
    "                 (vector-set! port 2 (cons (+ pos n) end))\n"
    "                 result)))))\n"
    "        ((bytevector-input-port? port)\n"
    "         (error \"read-bytevector: port is closed\"))\n"
    "        (else\n"
    "         (prim-read-bytevector k port)))))))\n"
    "\n"
    ";; Wrap read-bytevector! to support bytevector input ports.\n"
    "(let ((prim-read-bytevector! read-bytevector!))\n"
    "  (set! read-bytevector!\n"
    "    (lambda (target . args)\n"
    "      (if (not (bytevector? target))\n"
    "          (error \"read-bytevector!: expected a bytevector\"))\n"
    "      (if (> (length args) 3)\n"
    "          (error \"read-bytevector!: too many arguments\"))\n"
    "      (let* ((port (if (pair? args) (car args) (current-input-port)))\n"
    "             (rest (if (pair? args) (cdr args) '()))\n"
    "             (start (if (pair? rest) (car rest) 0))\n"
    "             (rest2 (if (pair? rest) (cdr rest) '()))\n"
    "             (end (if (pair? rest2) (car rest2)\n"
    "                      (bytevector-length target))))\n"
    "        (if (or (not (exact-nonnegative-integer? start))\n"
    "                (not (exact-nonnegative-integer? end))\n"
    "                (> start end)\n"
    "                (> end (bytevector-length target)))\n"
    "            (error \"read-bytevector!: invalid bytevector range\"))\n"
    "        (cond\n"
    "          ((bytevector-input-port-open? port)\n"
    "           (let* ((bv (vector-ref port 1))\n"
    "                  (state (vector-ref port 2))\n"
    "                  (pos (car state))\n"
    "                  (port-end (cdr state))\n"
    "                  (available (- port-end pos))\n"
    "                  (count (- end start)))\n"
    "             (if (= count 0)\n"
    "                 0\n"
    "                 (if (<= available 0)\n"
    "                     (eof-object)\n"
    "                     (let ((n (min count available)))\n"
    "                       (let loop ((i 0))\n"
    "                         (if (= i n)\n"
    "                             #t\n"
    "                             (begin\n"
    "                               (bytevector-u8-set!\n"
    "                                target (+ start i)\n"
    "                                (bytevector-u8-ref bv (+ pos i)))\n"
    "                               (loop (+ i 1)))))\n"
    "                       (vector-set! port 2 (cons (+ pos n) port-end))\n"
    "                       n)))))\n"
    "          ((bytevector-input-port? port)\n"
    "           (error \"read-bytevector!: port is closed\"))\n"
    "          (else\n"
    "           (apply prim-read-bytevector! (cons target args))))))))\n"
    "\n"
    ";; peek-u8/u8-ready? are C primitives that only understand real ports;\n"
    ";; wrap them the same way read-u8/read-bytevector are wrapped above so\n"
    ";; they also accept the vector-based bytevector input ports.\n"
    "(let ((primitive-peek-u8 peek-u8)\n"
    "      (primitive-u8-ready? u8-ready?))\n"
    "  (set! peek-u8\n"
    "    (lambda opt-port\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"peek-u8: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-input-port))))\n"
    "        (cond\n"
    "          ((bytevector-input-port-open? port)\n"
    "           (let* ((bv (vector-ref port 1))\n"
    "                  (state (vector-ref port 2))\n"
    "                  (pos (car state))\n"
    "                  (end (cdr state)))\n"
    "             (if (>= pos end)\n"
    "                 (eof-object)\n"
    "                 (bytevector-u8-ref bv pos))))\n"
    "          ((bytevector-input-port? port)\n"
    "           (error \"peek-u8: port is closed\"))\n"
    "          ((not (binary-port? port))\n"
    "           (error \"peek-u8: not a binary input port\"))\n"
    "          (else\n"
    "           (apply primitive-peek-u8 opt-port))))))\n"
    "  (set! u8-ready?\n"
    "    (lambda opt-port\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"u8-ready?: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port) (car opt-port) (current-input-port))))\n"
    "        (cond\n"
    "          ((bytevector-input-port-open? port) #t)\n"
    "          ((bytevector-input-port? port)\n"
    "           (error \"u8-ready?: port is closed\"))\n"
    "          ((not (binary-port? port))\n"
    "           (error \"u8-ready?: not a binary input port\"))\n"
    "          (else\n"
    "           (apply primitive-u8-ready? opt-port)))))))\n"
    "\n"
    "(let ((primitive-input-port? input-port?)\n"
    "      (primitive-output-port? output-port?)\n"
    "      (primitive-input-port-open? input-port-open?)\n"
    "      (primitive-output-port-open? output-port-open?)\n"
    "      (primitive-textual-port? textual-port?)\n"
    "      (primitive-binary-port? binary-port?)\n"
    "      (primitive-close-input-port close-input-port)\n"
    "      (primitive-close-output-port close-output-port)\n"
    "      (primitive-flush-output-port flush-output-port))\n"
    "  (set! input-port?\n"
    "    (lambda (obj)\n"
    "      (or (bytevector-input-port? obj)\n"
    "          (primitive-input-port? obj))))\n"
    "  (set! output-port?\n"
    "    (lambda (obj)\n"
    "      (or (bytevector-output-port? obj)\n"
    "          (primitive-output-port? obj))))\n"
    "  (set! input-port-open?\n"
    "    (lambda (obj)\n"
    "      (if (bytevector-input-port? obj)\n"
    "          (bytevector-input-port-open? obj)\n"
    "          (primitive-input-port-open? obj))))\n"
    "  (set! output-port-open?\n"
    "    (lambda (obj)\n"
    "      (if (bytevector-output-port? obj)\n"
    "          (bytevector-output-port-open? obj)\n"
    "          (primitive-output-port-open? obj))))\n"
    "  (set! flush-output-port\n"
    "    (lambda opt-port\n"
    "      (if (> (length opt-port) 1)\n"
    "          (error \"flush-output-port: expected at most one port\"))\n"
    "      (let ((port (if (pair? opt-port)\n"
    "                      (car opt-port)\n"
    "                      (current-output-port))))\n"
    "        (cond\n"
    "          ((bytevector-output-port-open? port) #f)\n"
    "          ((bytevector-output-port? port)\n"
    "           (error \"flush-output-port: port is closed\"))\n"
    "          (else\n"
    "           (apply primitive-flush-output-port opt-port))))))\n"
    "  (set! textual-port?\n"
    "    (lambda (obj)\n"
    "      (and (not (or (bytevector-input-port? obj)\n"
    "                    (bytevector-output-port? obj)))\n"
    "           (primitive-textual-port? obj))))\n"
    "  (set! binary-port?\n"
    "    (lambda (obj)\n"
    "      (or (bytevector-input-port? obj)\n"
    "          (bytevector-output-port? obj)\n"
    "          (primitive-binary-port? obj))))\n"
    "  (set! close-input-port\n"
    "    (lambda (port)\n"
    "      (if (bytevector-input-port-open? port)\n"
    "          (vector-set! port 0 'bvin-closed)\n"
    "          (if (bytevector-input-port? port)\n"
    "              #f\n"
    "              (primitive-close-input-port port)))))\n"
    "  (set! close-output-port\n"
    "    (lambda (port)\n"
    "      (if (bytevector-output-port-open? port)\n"
    "          (vector-set! port 0 'bvout-closed)\n"
    "          (if (bytevector-output-port? port)\n"
    "              #f\n"
    "              (primitive-close-output-port port))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; When/Unless macros (R7RS)\n"
    ";;; ============================================================================\n"
    "\n"
    "(define-syntax when\n"
    "  (syntax-rules ()\n"
    "    ((when test body ...)\n"
    "     (if test (begin body ...)))))\n"
    "\n"
    "(define-syntax unless\n"
    "  (syntax-rules ()\n"
    "    ((unless test body ...)\n"
    "     (if (not test) (begin body ...)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Guard (R7RS exception handling)\n"
    ";;; ============================================================================\n"
    "\n"
    "(define primitive-error error)\n"
    "(define *error-object-tag* (list 'error-object))\n"
    "\n"
    "(define (make-error-object kind message irritants)\n"
    "  (vector *error-object-tag* kind message irritants))\n"
    "\n"
    "(define (error-object? obj)\n"
    "  (and (vector? obj)\n"
    "       (= (vector-length obj) 4)\n"
    "       (eq? (vector-ref obj 0) *error-object-tag*)))\n"
    "\n"
    "(define (error-object-message obj)\n"
    "  (if (error-object? obj)\n"
    "      (vector-ref obj 2)\n"
    "      (primitive-error \"error-object-message: not an error object\")))\n"
    "\n"
    "(define (error-object-irritants obj)\n"
    "  (if (error-object? obj)\n"
    "      (vector-ref obj 3)\n"
    "      (primitive-error \"error-object-irritants: not an error object\")))\n"
    "\n"
    "(define (read-error? obj)\n"
    "  (and (error-object? obj) (eq? (vector-ref obj 1) 'read)))\n"
    "\n"
    "(define (file-error? obj)\n"
    "  (and (error-object? obj) (eq? (vector-ref obj 1) 'file)))\n"
    "\n"
    ";; Simple exception system using continuations\n"
    ";; The default handler prints and returns. It deliberately does not exit:\n"
    ";; unhandled errors propagate as TOK_ERROR to the C boundary, which restores\n"
    ";; the baseline exception state (see eval_expr in main.c), so an interactive\n"
    ";; REPL survives an unhandled error instead of losing the session.\n"
    ";; Handlers take an optional second argument saying whether the raise was\n"
    ";; continuable. Every engine-side dispatch site (vm.c, eval.c) applies the\n"
    ";; handler to one argument, which means non-continuable; only\n"
    ";; raise-continuable passes the flag.\n"
    "(define (*default-exception-handler* exn . continuable)\n"
    "  (display \"Unhandled exception: \")\n"
    "  (display exn)\n"
    "  (newline)\n"
    "  (set! *wind-stack* '())\n"
    "  #f)\n"
    "(define *current-exception-handler* *default-exception-handler*)\n"
    "\n"
    ";; Per R7RS 6.11, a handler invoked by raise/raise-continuable must run\n"
    ";; with the PREVIOUS handler in effect (not itself), so that a handler\n"
    ";; which re-raises (e.g. a guard clause that falls through) propagates to\n"
    ";; the enclosing handler instead of calling itself forever. We install a\n"
    ";; wrapper that swaps back to the previous handler for the duration of the\n"
    ";; user handler's call, restoring itself afterward if the handler returns\n"
    ";; (the raise-continuable case).\n"
    "(define (with-exception-handler handler thunk)\n"
    "  (let ((old-handler *current-exception-handler*))\n"
    "    (letrec ((wrapped-handler\n"
    "               (lambda (obj . continuable)\n"
    "                 (dynamic-wind\n"
    "                   (lambda () (set! *current-exception-handler* old-handler))\n"
    "                   (lambda ()\n"
    "                     (let ((result (handler obj)))\n"
    "                       (if (and (pair? continuable) (car continuable))\n"
    "                           result\n"
    "                           ;; The handler returned from a non-continuable\n"
    "                           ;; raise. R7RS 6.11 raises a secondary exception\n"
    "                           ;; \"in the same dynamic environment as the\n"
    "                           ;; handler\" - i.e. right here, where old-handler\n"
    "                           ;; is installed - so an enclosing guard or\n"
    "                           ;; with-exception-handler can catch it. Raising\n"
    "                           ;; after the dynamic-wind has restored\n"
    "                           ;; wrapped-handler would instead re-enter the\n"
    "                           ;; handler that just returned.\n"
    "                           (raise (make-error-object\n"
    "                                   'error\n"
    "                                   \"handler returned from non-continuable exception\"\n"
    "                                   '())))))\n"
    "                   (lambda () (set! *current-exception-handler* wrapped-handler))))))\n"
    "      (dynamic-wind\n"
    "        (lambda () (set! *current-exception-handler* wrapped-handler))\n"
    "        thunk\n"
    "        (lambda () (set! *current-exception-handler* old-handler))))))\n"
    "\n"
    ";; raise dispatches through raise-now (engine machinery) with a pinned\n"
    ";; return marker. A wrapped handler never returns from a non-continuable\n"
    ";; raise (it raises the secondary exception above), so the marker now only\n"
    ";; fires for the default handler - the designed unhandled path, already\n"
    ";; reported - or for a bare procedure installed directly into\n"
    ";; *current-exception-handler*, which stays an engine-level error.\n"
    "(define (raise obj)\n"
    "  (raise-now obj))\n"
    "\n"
    "(define (raise-continuable obj)\n"
    "  (*current-exception-handler* obj #t))\n"
    "\n"
    "(define (error message . irritants)\n"
    "  (raise (make-error-object 'error message irritants)))\n"
    "\n"
    "(define (syntax-error message . irritants)\n"
    "  (raise (make-error-object 'read message irritants)))\n"
    "\n"
    "(define-syntax guard\n"
    "  (syntax-rules ()\n"
    "    ((guard (var clause ...) body ...)\n"
    "     (call/cc\n"
    "       (lambda (guard-exit)\n"
    "         (with-exception-handler\n"
    "           (lambda (var)\n"
    "             (guard-exit\n"
    "               (guard-aux var clause ...)))\n"
    "           (lambda ()\n"
    "             body ...)))))))\n"
    "\n"
    "(define-syntax guard-aux\n"
    "  (syntax-rules (else)\n"
    "    ((guard-aux var (else result ...))\n"
    "     (begin result ...))\n"
    "    ((guard-aux var (test result ...))\n"
    "     (if test (begin result ...) (raise var)))\n"
    "    ((guard-aux var (test result ...) clause ...)\n"
    "     (if test (begin result ...) (guard-aux var clause ...)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Case and Do macros\n"
    ";;; ============================================================================\n"
    "\n"
    "; case - multi-way branch\n"
    "; R7RS 4.2.1 allows both ((datum ...) result ...) and ((datum ...) => proc)\n"
    "; clause shapes, plus (else result ...) and (else => proc). The => clauses\n"
    "; must come first: otherwise (=> proc) matches result ... and expands to\n"
    "; (begin => proc), which fails with \"undefined variable: =>\".\n"
    "(define-syntax %case-dispatch\n"
    "  (syntax-rules (else =>)\n"
    "    ((%case-dispatch key (else => proc))\n"
    "     (proc key))\n"
    "    ((%case-dispatch key (else result ...))\n"
    "     (begin result ...))\n"
    "    ((%case-dispatch key ((atoms ...) => proc))\n"
    "     (if (memv key '(atoms ...))\n"
    "         (proc key)))\n"
    "    ((%case-dispatch key ((atoms ...) => proc) clause ...)\n"
    "     (if (memv key '(atoms ...))\n"
    "         (proc key)\n"
    "         (%case-dispatch key clause ...)))\n"
    "    ((%case-dispatch key ((atoms ...) result ...))\n"
    "     (if (memv key '(atoms ...))\n"
    "         (begin result ...)))\n"
    "    ((%case-dispatch key ((atoms ...) result ...) clause ...)\n"
    "     (if (memv key '(atoms ...))\n"
    "         (begin result ...)\n"
    "         (%case-dispatch key clause ...)))))\n"
    "\n"
    "(define-syntax case\n"
    "  (syntax-rules ()\n"
    "    ((case key clause ...)\n"
    "     (let ((case-key key))\n"
    "       (%case-dispatch case-key clause ...)))))\n"
    "\n"
    "; do - iteration (uses nested ellipsis)\n"
    "; do - iteration (uses nested ellipsis for any number of variables)\n"
    "(define-syntax do\n"
    "  (syntax-rules ()\n"
    "    ((do ((var init step ...) ...)\n"
    "         (test expr ...)\n"
    "       command ...)\n"
    "     (letrec ((loop\n"
    "               (lambda (var ...)\n"
    "                 (if test\n"
    "                     (begin #f expr ...)\n"
    "                     (begin\n"
    "                       command ...\n"
    "                       (loop (do-step var step ...) ...))))))\n"
    "       (loop init ...)))\n"
    "    ))\n"
    "\n"
    "(define-syntax do-step\n"
    "  (syntax-rules ()\n"
    "    ((do-step var) var)\n"
    "    ((do-step var step) step)))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; List accessors (compositions of car/cdr)\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (caar x) (car (car x)))\n"
    "(define (cadr x) (car (cdr x)))\n"
    "(define (cdar x) (cdr (car x)))\n"
    "(define (cddr x) (cdr (cdr x)))\n"
    "\n"
    "(define (caaar x) (car (car (car x))))\n"
    "(define (caadr x) (car (car (cdr x))))\n"
    "(define (cadar x) (car (cdr (car x))))\n"
    "(define (caddr x) (car (cdr (cdr x))))\n"
    "(define (cdaar x) (cdr (car (car x))))\n"
    "(define (cdadr x) (cdr (car (cdr x))))\n"
    "(define (cddar x) (cdr (cdr (car x))))\n"
    "(define (cdddr x) (cdr (cdr (cdr x))))\n"
    "\n"
    "(define (caaaar x) (car (car (car (car x)))))\n"
    "(define (caaadr x) (car (car (car (cdr x)))))\n"
    "(define (caadar x) (car (car (cdr (car x)))))\n"
    "(define (caaddr x) (car (car (cdr (cdr x)))))\n"
    "(define (cadaar x) (car (cdr (car (car x)))))\n"
    "(define (cadadr x) (car (cdr (car (cdr x)))))\n"
    "(define (caddar x) (car (cdr (cdr (car x)))))\n"
    "(define (cadddr x) (car (cdr (cdr (cdr x)))))\n"
    "(define (cdaaar x) (cdr (car (car (car x)))))\n"
    "(define (cdaadr x) (cdr (car (car (cdr x)))))\n"
    "(define (cdadar x) (cdr (car (cdr (car x)))))\n"
    "(define (cdaddr x) (cdr (car (cdr (cdr x)))))\n"
    "(define (cddaar x) (cdr (cdr (car (car x)))))\n"
    "(define (cddadr x) (cdr (cdr (car (cdr x)))))\n"
    "(define (cdddar x) (cdr (cdr (cdr (car x)))))\n"
    "(define (cddddr x) (cdr (cdr (cdr (cdr x)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; List utilities\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (%require-proper-list who lst)\n"
    "  (if (list? lst)\n"
    "      lst\n"
    "      (error (string-append who \": expected proper list\"))))\n"
    "\n"
    "(define (%require-nonnegative-integer who k)\n"
    "  (if (and (integer? k) (exact? k) (>= k 0))\n"
    "      k\n"
    "      (error (string-append who \": expected nonnegative integer\"))))\n"
    "\n"
    "(define (%require-exact-integer who k)\n"
    "  (if (and (integer? k) (exact? k))\n"
    "      k\n"
    "      (error (string-append who \": expected exact integer\"))))\n"
    "\n"
    "(define (%require-procedure who proc)\n"
    "  (if (procedure? proc)\n"
    "      proc\n"
    "      (error (string-append who \": expected procedure\"))))\n"
    "\n"
    "; Like %require-proper-list, but allows a non-nil final cdr (an improper/\n"
    "; dotted list), as several R7RS/SRFI-1 procedures explicitly permit.\n"
    "; Still rejects circular lists (Floyd's cycle detection) so callers can't\n"
    "; hang walking one.\n"
    "(define (%require-finite-list who lst)\n"
    "  ; Non-pair values are zero-length dotted lists in SRFI-1 terminology.\n"
    "  (let loop ((slow lst) (fast lst))\n"
    "    (cond ((not (pair? fast)) lst)\n"
    "          ((not (pair? (cdr fast))) lst)\n"
    "          (else\n"
    "           (let ((fast2 (cddr fast)) (slow2 (cdr slow)))\n"
    "             (if (eq? fast2 slow2)\n"
    "                 (error (string-append who \": circular list\"))\n"
    "                 (loop slow2 fast2)))))))\n"
    "\n"
    "; Like %require-proper-lists, but the LAST element of `lists` may be any\n"
    "; object (R7RS `append`'s convention: every argument but the last must be\n"
    "; a list, and the last is used as-is, becoming the final tail).\n"
    "(define (%require-proper-lists-but-last who lists)\n"
    "  (if (pair? lists)\n"
    "      (let loop ((lists lists))\n"
    "        (if (pair? (cdr lists))\n"
    "            (begin\n"
    "              (%require-proper-list who (car lists))\n"
    "              (loop (cdr lists)))\n"
    "            lists))\n"
    "      lists))\n"
    "\n"
    "(define (%require-proper-lists who lists)\n"
    "  (%require-proper-list who lists)\n"
    "  (let loop ((lists lists))\n"
    "    (if (not (null? lists))\n"
    "        (begin\n"
    "          (%require-proper-list who (car lists))\n"
    "          (loop (cdr lists)))))\n"
    "  lists)\n"
    "\n"
    "(define (list-ref lst k)\n"
    "  (%require-nonnegative-integer \"list-ref\" k)\n"
    "  (let loop ((lst lst) (k k))\n"
    "    (cond ((not (pair? lst)) (error \"list-ref: index out of bounds\"))\n"
    "          ((= k 0) (car lst))\n"
    "          (else (loop (cdr lst) (- k 1))))))\n"
    "\n"
    "(define (list-tail lst k)\n"
    "  (%require-nonnegative-integer \"list-tail\" k)\n"
    "  (let loop ((lst lst) (k k))\n"
    "    (cond ((= k 0) lst)\n"
    "          ((not (pair? lst)) (error \"list-tail: index out of bounds\"))\n"
    "          (else (loop (cdr lst) (- k 1))))))\n"
    "\n"
    "; Membership functions\n"
    "(define (memq obj lst)\n"
    "  (let loop ((lst lst))\n"
    "    (cond ((null? lst) #f)\n"
    "          ((not (pair? lst)) (error \"memq: improper list\"))\n"
    "          ((eq? obj (car lst)) lst)\n"
    "          (else (loop (cdr lst))))))\n"
    "\n"
    "(define (memv obj lst)\n"
    "  (let loop ((lst lst))\n"
    "    (cond ((null? lst) #f)\n"
    "          ((not (pair? lst)) (error \"memv: improper list\"))\n"
    "          ((eqv? obj (car lst)) lst)\n"
    "          (else (loop (cdr lst))))))\n"
    "\n"
    "(define (member obj lst . maybe-compare)\n"
    "  (if (> (length maybe-compare) 1)\n"
    "      (error \"member: too many arguments\"))\n"
    "  (if (null? lst)\n"
    "      #f\n"
    "      (let ((compare (%require-procedure\n"
    "                      \"member\"\n"
    "                      (if (null? maybe-compare) equal? (car maybe-compare)))))\n"
    "        (let loop ((lst lst))\n"
    "          (cond ((null? lst) #f)\n"
    "                ((not (pair? lst)) (error \"member: improper list\"))\n"
    "                ((compare obj (car lst)) lst)\n"
    "                (else (loop (cdr lst))))))))\n"
    "\n"
    "(define (member-procedure predicate)\n"
    "  (lambda (obj lst)\n"
    "    (let loop ((lst lst))\n"
    "      (cond ((null? lst) #f)\n"
    "            ((not (pair? lst)) (error \"member-procedure: improper list\"))\n"
    "            ((predicate obj (car lst)) lst)\n"
    "            (else (loop (cdr lst)))))))\n"
    "\n"
    "; Association list functions\n"
    "(define (alist? object)\n"
    "  (and (proper-list? object)\n"
    "       (let loop ((alist object))\n"
    "         (or (null? alist)\n"
    "             (and (pair? (car alist))\n"
    "                  (loop (cdr alist)))))))\n"
    "\n"
    "(define (assq obj alist)\n"
    "  (let loop ((alist alist))\n"
    "    (cond ((null? alist) #f)\n"
    "          ((not (pair? alist)) (error \"assq: improper association list\"))\n"
    "          ((eq? obj (caar alist)) (car alist))\n"
    "          (else (loop (cdr alist))))))\n"
    "\n"
    "(define (assv obj alist)\n"
    "  (let loop ((alist alist))\n"
    "    (cond ((null? alist) #f)\n"
    "          ((not (pair? alist)) (error \"assv: improper association list\"))\n"
    "          ((eqv? obj (caar alist)) (car alist))\n"
    "          (else (loop (cdr alist))))))\n"
    "\n"
    "(define (assoc obj alist . maybe-compare)\n"
    "  (if (> (length maybe-compare) 1)\n"
    "      (error \"assoc: too many arguments\"))\n"
    "  (if (null? alist)\n"
    "      #f\n"
    "      (begin\n"
    "        (let ((compare (%require-procedure\n"
    "                        \"assoc\"\n"
    "                        (if (null? maybe-compare) equal? (car maybe-compare)))))\n"
    "          (let loop ((alist alist))\n"
    "            (cond ((null? alist) #f)\n"
    "                  ((not (pair? alist))\n"
    "                   (error \"assoc: improper association list\"))\n"
    "                  ((compare obj (caar alist)) (car alist))\n"
    "                  (else (loop (cdr alist)))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Numeric predicates\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (zero? n) (= n 0))\n"
    "(define (positive? n) (> n 0))\n"
    "(define (negative? n) (< n 0))\n"
    "(define (odd? n) (not (= (remainder n 2) 0)))\n"
    "(define (even? n) (= (remainder n 2) 0))\n"
    "\n"
    "; R7RS 6.2.6: if any argument to min/max is inexact, the result is inexact,\n"
    "; even when the selected operand is the exact one. Selection and exactness\n"
    "; are decided separately - the operand that wins the comparison is kept as\n"
    "; is, then coerced once at the end if any argument was inexact.\n"
    "(define (%any-inexact? x rest)\n"
    "  (if (inexact? x)\n"
    "      #t\n"
    "      (if (null? rest)\n"
    "          #f\n"
    "          (%any-inexact? (car rest) (cdr rest)))))\n"
    "\n"
    "(define (%minmax-result value x rest)\n"
    "  (if (and (exact? value) (%any-inexact? x rest))\n"
    "      (exact->inexact value)\n"
    "      value))\n"
    "\n"
    "(define (max x . rest)\n"
    "  (define (select x rest)\n"
    "    (if (null? rest)\n"
    "        x\n"
    "        (let ((m (select (car rest) (cdr rest))))\n"
    "          (if (> x m) x m))))\n"
    "  (%minmax-result (select x rest) x rest))\n"
    "\n"
    "(define (min x . rest)\n"
    "  (define (select x rest)\n"
    "    (if (null? rest)\n"
    "        x\n"
    "        (let ((m (select (car rest) (cdr rest))))\n"
    "          ; Use the reversed comparison so NaNs and signed zeros follow the\n"
    "          ; same operand-selection behavior as MIT/GNU Scheme: keep x unless\n"
    "          ; the accumulated minimum is strictly greater than it.\n"
    "          (if (> x m) m x))))\n"
    "  (%minmax-result (select x rest) x rest))\n"
    "\n"
    "; Inexactness is contagious through gcd/lcm the same way it is through the\n"
    "; other numeric operators, including via the zero short-circuits: gcd2's base\n"
    "; case discards b, and lcm2's returns a fresh 0, so a zero operand would\n"
    "; otherwise silently drop the inexactness of the whole call. Track it across\n"
    "; the argument list and coerce once at the end.\n"
    "(define (gcd . args)\n"
    "  (define (gcd2 a b)\n"
    "    (if (= b 0)\n"
    "        (abs a)\n"
    "        (gcd2 b (remainder a b))))\n"
    "  (if (null? args)\n"
    "      0\n"
    "      (let loop ((result (car args))\n"
    "                 (rest (cdr args))\n"
    "                 (any-inexact? (inexact? (car args))))\n"
    "        (if (null? rest)\n"
    "            (let ((g (abs result)))\n"
    "              (if (and any-inexact? (exact? g)) (exact->inexact g) g))\n"
    "            (loop (gcd2 result (car rest))\n"
    "                  (cdr rest)\n"
    "                  (or any-inexact? (inexact? (car rest))))))))\n"
    "\n"
    "(define (lcm . args)\n"
    "  (define (lcm2 a b)\n"
    "    (if (or (= a 0) (= b 0))\n"
    "        0\n"
    "        (abs (quotient (* a b) (gcd a b)))))\n"
    "  (if (null? args)\n"
    "      1\n"
    "      (let loop ((result (car args))\n"
    "                 (rest (cdr args))\n"
    "                 (any-inexact? (inexact? (car args))))\n"
    "        (if (null? rest)\n"
    "            (let ((l (abs result)))\n"
    "              (if (and any-inexact? (exact? l)) (exact->inexact l) l))\n"
    "            (loop (lcm2 result (car rest))\n"
    "                  (cdr rest)\n"
    "                  (or any-inexact? (inexact? (car rest))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Higher-order functions\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (map proc lst . lsts)\n"
    "  ; MIT does not inspect the procedure or companion arguments when the\n"
    "  ; first list is already empty.  Keep that short-circuit before validating\n"
    "  ; circular/proper companion lists, while retaining the checks for every\n"
    "  ; call that will actually traverse the input.\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-circular-lists \"map\" (cons lst lsts))\n"
    "        (if (null? lsts)\n"
    "            ; Keep accumulated prefixes immutable. A continuation captured\n"
    "            ; by proc can return through map repeatedly; an earlier result\n"
    "            ; must not be modified by a later return (R7RS 6.10).\n"
    "            (let loop ((lst lst) (acc '()))\n"
    "              (if (null? lst)\n"
    "                  (reverse acc)\n"
    "                  (let ((value (proc (car lst))))\n"
    "                    (loop (cdr lst) (cons value acc)))))\n"
    "            (let loop ((lst lst) (lsts lsts) (acc '()))\n"
    "              (if (or (null-list? lst) (%search-list-end? lsts))\n"
    "                  (reverse acc)\n"
    "                  (let ((value (apply proc (car lst) (map car lsts))))\n"
    "                    (loop (cdr lst) (map cdr lsts) (cons value acc)))))))))\n"
    "\n"
    "; SRFI-1's map-in-order is the deterministic counterpart to map.  This\n"
    "; implementation already evaluates map's procedure calls left-to-right.\n"
    "(define map-in-order map)\n"
    "\n"
    "(define (for-each proc lst . lsts)\n"
    "  ; As with map, an empty first list means no procedure or companion is\n"
    "  ; inspected.  This is observable with invalid unused arguments in MIT.\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-circular-lists \"for-each\" (cons lst lsts))\n"
    "        (if (null? lsts)\n"
    "            ; Single list case.  Keep the traversal in tail position so a\n"
    "            ; large proper list does not consume one Scheme stack frame per\n"
    "            ; element.\n"
    "            (let loop ((lst lst))\n"
    "              (if (not (null-list? lst))\n"
    "                  (begin\n"
    "                    (proc (car lst))\n"
    "                    (loop (cdr lst)))))\n"
    "            ; Multiple lists case.  Stop at the first finite list, while\n"
    "            ; allowing circular companions as SRFI-1 does.\n"
    "            (let loop ((lst lst) (lsts lsts))\n"
    "              (if (not (or (null-list? lst) (%search-list-end? lsts)))\n"
    "                  (begin\n"
    "                    (apply proc (car lst) (map car lsts))\n"
    "                    (loop (cdr lst) (map cdr lsts)))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional utilities\n"
    ";;; ============================================================================\n"
    "\n"
    "; not is already a primitive, but define it for completeness\n"
    "; (define (not x) (if x #f #t))\n"
    "\n"
    "(define *promise-tag* (list 'promise))\n"
    "\n"
    "(define (%make-lazy-promise thunk)\n"
    "  (vector *promise-tag* (cons #f thunk)))\n"
    "\n"
    "(define (%make-eager-promise value)\n"
    "  (vector *promise-tag* (cons #t value)))\n"
    "\n"
    "(define (make-promise obj)\n"
    "  (if (promise? obj)\n"
    "      obj\n"
    "      (%make-eager-promise obj)))\n"
    "\n"
    "(define (promise? obj)\n"
    "  (and (vector? obj)\n"
    "       (= (vector-length obj) 2)\n"
    "       (eq? (vector-ref obj 0) *promise-tag*)))\n"
    "\n"
    "; Force/delay\n"
    "(define-syntax delay\n"
    "  (syntax-rules ()\n"
    "    ((delay expr)\n"
    "     (%make-lazy-promise (lambda () (%make-eager-promise expr))))))\n"
    "\n"
    "(define (force promise)\n"
    "  (if (not (promise? promise))\n"
    "      (error \"force: not a promise\")\n"
    "      ; Promises joined by delay-force share a mutable state pair. Updating\n"
    "      ; that pair memoizes every alias without retaining a chain of thunks.\n"
    "      (let loop ()\n"
    "        (let ((state (vector-ref promise 1)))\n"
    "          (if (car state)\n"
    "              (cdr state)\n"
    "              (let* ((next ((cdr state)))\n"
    "                     ; The thunk can recursively force this same promise.\n"
    "                     ; Re-read its state and preserve any value cached there.\n"
    "                     (state (vector-ref promise 1)))\n"
    "                (if (not (car state))\n"
    "                    (if (not (promise? next))\n"
    "                        (error \"delay-force: expected a promise\")\n"
    "                        (let ((next-state (vector-ref next 1)))\n"
    "                          (set-car! state (car next-state))\n"
    "                          (set-cdr! state (cdr next-state))\n"
    "                          (vector-set! next 1 state))))\n"
    "                (loop)))))))\n"
    "\n"
    "(define-syntax delay-force\n"
    "  (syntax-rules ()\n"
    "    ((delay-force expr)\n"
    "     (%make-lazy-promise (lambda () expr)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; File I/O forms (R3RS)\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (call-with-input-file filename proc)\n"
    "  (let ((port (open-input-file filename)))\n"
    "    (call-with-port port proc)))\n"
    "\n"
    "(define (call-with-output-file filename proc)\n"
    "  (let ((port (open-output-file filename)))\n"
    "    (call-with-port port proc)))\n"
    "\n"
    "; with-input-from-file temporarily redirects current-input-port\n"
    "(define (with-input-from-file filename thunk)\n"
    "  (let* ((new-port (open-input-file filename))\n"
    "         (old-port (current-input-port))\n"
    "         (returned? #f))\n"
    "    (dynamic-wind\n"
    "      (lambda () (set-current-input-port! new-port))\n"
    "      (lambda ()\n"
    "        (call-with-values\n"
    "          thunk\n"
    "          (lambda results\n"
    "            (set! returned? #t)\n"
    "            (apply values results))))\n"
    "      (lambda ()\n"
    "        (set-current-input-port! old-port)\n"
    "        (if returned?\n"
    "            (close-input-port new-port))))))\n"
    "\n"
    "; with-output-to-file temporarily redirects current-output-port\n"
    "(define (with-output-to-file filename thunk)\n"
    "  (let* ((new-port (open-output-file filename))\n"
    "         (old-port (current-output-port))\n"
    "         (returned? #f))\n"
    "    (dynamic-wind\n"
    "      (lambda () (set-current-output-port! new-port))\n"
    "      (lambda ()\n"
    "        (call-with-values\n"
    "          thunk\n"
    "          (lambda results\n"
    "            (set! returned? #t)\n"
    "            (apply values results))))\n"
    "      (lambda ()\n"
    "        (set-current-output-port! old-port)\n"
    "        (if returned?\n"
    "            (close-output-port new-port))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; String port convenience functions\n"
    ";;; ============================================================================\n"
    "\n"
    "; Call proc with a fresh output string port, return accumulated string\n"
    "(define (call-with-output-string proc)\n"
    "  (let ((port (open-output-string)))\n"
    "    (proc port)\n"
    "    (get-output-string port)))\n"
    "\n"
    "; Call proc with an input string port reading from str\n"
    "(define (call-with-input-string str proc)\n"
    "  (let ((port (open-input-string str)))\n"
    "    (proc port)))\n"
    "\n"
    "(define (%with-output-to-string thunk)\n"
    "  (let ((port (open-output-string))\n"
    "        (old-port (current-output-port)))\n"
    "    (dynamic-wind\n"
    "      (lambda () (set-current-output-port! port))\n"
    "      thunk\n"
    "      (lambda () (set-current-output-port! old-port)))\n"
    "    (get-output-string port)))\n"
    "\n"
    "(define (%with-input-from-string str thunk)\n"
    "  (let ((port (open-input-string str))\n"
    "        (old-port (current-input-port)))\n"
    "    (dynamic-wind\n"
    "      (lambda () (set-current-input-port! port))\n"
    "      thunk\n"
    "      (lambda () (set-current-input-port! old-port)))))\n"
    "\n"
    "; Execute thunk with output captured to a string\n"
    "(define-syntax with-output-to-string\n"
    "  (syntax-rules ()\n"
    "    ((with-output-to-string body ...)\n"
    "     (%with-output-to-string (lambda () body ...)))))\n"
    "\n"
    "; Execute thunk with input coming from a string\n"
    "(define-syntax with-input-from-string\n"
    "  (syntax-rules ()\n"
    "    ((with-input-from-string str body ...)\n"
    "     (%with-input-from-string str (lambda () body ...)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; List Processing Utilities (SRFI-1 style)\n"
    ";;; ============================================================================\n"
    "\n"
    "; filter - return list of elements satisfying predicate (tail-recursive, in-order)\n"
    "(define (filter pred lst)\n"
    "  (%require-proper-list \"filter\" lst)\n"
    "  (let loop ((lst lst) (acc '()))\n"
    "    (cond ((null? lst) (reverse acc))\n"
    "          ((pred (car lst)) (loop (cdr lst) (cons (car lst) acc)))\n"
    "          (else (loop (cdr lst) acc)))))\n"
    "\n"
    "; remove - return list of elements NOT satisfying predicate\n"
    "(define (remove pred lst)\n"
    "  (filter (lambda (x) (not (pred x))) lst))\n"
    "\n"
    "; Return procedures that remove matching elements from a list.\n"
    "(define (list-deletor pred)\n"
    "  (lambda (lst) (remove pred lst)))\n"
    "\n"
    "(define (list-deletor! pred)\n"
    "  (lambda (lst) (remove! pred lst)))\n"
    "\n"
    "; find - return first element satisfying predicate, or #f\n"
    "(define (find pred lst)\n"
    "  (let loop ((lst lst))\n"
    "    (cond ((null? lst) #f)\n"
    "          ((not (pair? lst)) (error \"find: improper list\"))\n"
    "          ((pred (car lst)) (car lst))\n"
    "          (else (loop (cdr lst))))))\n"
    "\n"
    "; any - return the predicate's true value for the first element(s) that\n"
    "; satisfy it (not a bare #t), stopping at the shortest of any number of\n"
    "; lists; #f if none satisfy (SRFI-1)\n"
    "(define (any pred lst . more-lists)\n"
    "  (if (null? lst)\n"
    "      #f\n"
    "      (let loop ((lsts (cons lst more-lists)))\n"
    "        (if (%search-list-end? lsts)\n"
    "            #f\n"
    "            (let ((next (map cdr lsts)))\n"
    "              (if (%search-list-end? next)\n"
    "                  (apply pred (map car lsts))\n"
    "                  (or (apply pred (map car lsts))\n"
    "                      (loop next))))))))\n"
    "\n"
    "; every - return the predicate's value for the last element(s) (not a bare\n"
    "; #t), stopping at the shortest of any number of lists; #t if all satisfy\n"
    "; (or any list is empty from the start) (SRFI-1)\n"
    "(define (every pred lst . more-lists)\n"
    "  (if (null? lst)\n"
    "      #t\n"
    "      (let loop ((lsts (cons lst more-lists)))\n"
    "        (if (%search-list-end? lsts)\n"
    "            #t\n"
    "            (let ((next (map cdr lsts)))\n"
    "              (if (%search-list-end? next)\n"
    "                  (apply pred (map car lsts))\n"
    "                  (and (apply pred (map car lsts))\n"
    "                       (loop next))))))))\n"
    "\n"
    "; Inspect only the current pairs. Successful searches need not validate\n"
    "; the unvisited tail; checking successors identifies the final tail call.\n"
    "(define (%search-list-end? lists)\n"
    "  (and (pair? lists)\n"
    "       (or (null-list? (car lists))\n"
    "           (%search-list-end? (cdr lists)))))\n"
    "\n"
    "; MIT's folds validate every current tail even if one has already ended.\n"
    "; Map and the other traversals stop inspecting arguments at the first end.\n"
    "(define (%fold-list-end? lists)\n"
    "  (let loop ((lists lists) (ended? #f))\n"
    "    (if (null? lists)\n"
    "        ended?\n"
    "        (loop (cdr lists) (or (null-list? (car lists)) ended?)))))\n"
    "\n"
    "(define (any-null? lsts)\n"
    "  (if (null? lsts) #f (or (null? (car lsts)) (any-null? (cdr lsts)))))\n"
    "\n"
    "; count - count elements satisfying predicate\n"
    "(define (count pred lst . more-lists)\n"
    "  (if (null? lst)\n"
    "      0\n"
    "      (begin\n"
    "        (%require-circular-lists \"count\" (cons lst more-lists))\n"
    "        (let loop ((lists (cons lst more-lists)) (n 0))\n"
    "          (if (%search-list-end? lists)\n"
    "              n\n"
    "              (loop (map cdr lists)\n"
    "                    (if (apply pred (map car lists))\n"
    "                        (+ n 1)\n"
    "                        n)))))))\n"
    "\n"
    "; fold - left-associative fold over one or more lists (SRFI-1).\n"
    "(define (fold proc init lst . more-lists)\n"
    "  (%require-circular-lists \"fold\" (cons lst more-lists))\n"
    "  (let loop ((lists (cons lst more-lists)) (acc init))\n"
    "    (if (%fold-list-end? lists)\n"
    "        acc\n"
    "        (loop (map cdr lists)\n"
    "              (apply proc (append (map car lists) (list acc)))))))\n"
    "\n"
    "; fold-right - right-associative fold over one or more lists (SRFI-1).\n"
    "(define (fold-right proc init lst . more-lists)\n"
    "  (%require-circular-lists \"fold-right\" (cons lst more-lists))\n"
    "  (let loop ((lists (cons lst more-lists)))\n"
    "    (if (%fold-list-end? lists)\n"
    "        init\n"
    "        (apply proc\n"
    "               (append (map car lists)\n"
    "                       (list (loop (map cdr lists))))))))\n"
    "\n"
    "; reduce - like fold but uses first element as initial value; returns\n"
    "; ridentity for an empty list (SRFI-1 signature: (reduce f ridentity list))\n"
    "(define (reduce proc ridentity lst)\n"
    "  (%require-proper-list \"reduce\" lst)\n"
    "  (if (null? lst)\n"
    "      ridentity\n"
    "      (fold proc (car lst) (cdr lst))))\n"
    "\n"
    "; take - return first n elements of list (SRFI-1/R7RS-large signature:\n"
    "; (take list k), matching MIT and every sibling function in this file)\n"
    "(define (take lst n)\n"
    "  (%require-nonnegative-integer \"take\" n)\n"
    "  (let loop ((n n) (lst lst))\n"
    "    ; The explicit count bounds circular-list traversal, but a finite list\n"
    "    ; must still contain every requested element.\n"
    "    (if (= n 0)\n"
    "        '()\n"
    "        (if (pair? lst)\n"
    "            (cons (car lst) (loop (- n 1) (cdr lst)))\n"
    "            (error \"take: list is shorter than requested count\")))))\n"
    "\n"
    "; drop - return list without first n elements (SRFI-1/R7RS-large\n"
    "; signature: (drop list k))\n"
    "(define (drop lst n)\n"
    "  (%require-nonnegative-integer \"drop\" n)\n"
    "  (let loop ((n n) (lst lst))\n"
    "    ; Preserve a dotted tail once the requested prefix has been skipped, but\n"
    "    ; reject a finite list that ends before all requested elements are gone.\n"
    "    (if (= n 0)\n"
    "        lst\n"
    "        (if (pair? lst)\n"
    "            (loop (- n 1) (cdr lst))\n"
    "            (error \"drop: list is shorter than requested count\")))))\n"
    "\n"
    "; partition - split list into two lists based on predicate\n"
    "(define (partition pred lst)\n"
    "  (%require-proper-list \"partition\" lst)\n"
    "  (let loop ((lst lst) (yes '()) (no '()))\n"
    "    (cond ((null? lst) (values (reverse yes) (reverse no)))\n"
    "          ((pred (car lst)) (loop (cdr lst) (cons (car lst) yes) no))\n"
    "          (else (loop (cdr lst) yes (cons (car lst) no))))))\n"
    "\n"
    "; zip - combine corresponding elements of one or more lists, stopping at the\n"
    "; shortest list (SRFI-1).\n"
    "(define (zip . lists)\n"
    "  (if (null? lists)\n"
    "      (error \"zip: expected at least one list\")\n"
    "      (apply map list lists)))\n"
    "\n"
    "; flatten - flatten nested list structure\n"
    "(define (flatten lst)\n"
    "  (if (pair? lst)\n"
    "      (%require-proper-list \"flatten\" lst))\n"
    "  (cond ((null? lst) '())\n"
    "        ((not (pair? lst)) (list lst))\n"
    "        (else (append (flatten (car lst)) (flatten (cdr lst))))))\n"
    "\n"
    "; last - return last element of list\n"
    "(define (last lst)\n"
    "  (%require-finite-list \"last\" lst)\n"
    "  (if (not (pair? lst))\n"
    "      (error \"last: expected non-empty list\"))\n"
    "  (car (last-pair lst)))\n"
    "\n"
    "; iota - generate a list of count numbers: start, start+step, ...\n"
    "; (SRFI-1/R7RS-large signature: (iota count [start [step]]))\n"
    "(define (iota count . args)\n"
    "  (%require-nonnegative-integer \"iota\" count)\n"
    "  (if (> (length args) 2)\n"
    "      (error \"iota: too many arguments\"))\n"
    "  (let ((start (if (pair? args) (car args) 0))\n"
    "        (step (if (and (pair? args) (pair? (cdr args))) (cadr args) 1)))\n"
    "    (let loop ((i (- count 1)) (acc '()))\n"
    "      (if (< i 0)\n"
    "          acc\n"
    "          (loop (- i 1) (cons (+ start (* i step)) acc))))))\n"
    "\n"
    "; range - generate list of integers [start, end)\n"
    "(define (range start end)\n"
    "  (%require-exact-integer \"range\" start)\n"
    "  (%require-exact-integer \"range\" end)\n"
    "  (let loop ((i (- end 1)) (acc '()))\n"
    "    (if (< i start)\n"
    "        acc\n"
    "        (loop (- i 1) (cons i acc)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Constructors\n"
    ";;; ============================================================================\n"
    "\n"
    "; circular-list - create a cyclic list.  The empty case is accepted as the\n"
    "; MIT/GNU extension, where it is simply the empty list.\n"
    "(define (circular-list . objects)\n"
    "  (if (null? objects)\n"
    "      '()\n"
    "      (let loop ((tail objects))\n"
    "        (if (null? (cdr tail))\n"
    "            (begin\n"
    "              (set-cdr! tail objects)\n"
    "              objects)\n"
    "            (loop (cdr tail))))))\n"
    "\n"
    "; make-circular-list - create a cyclic list of length k.\n"
    "(define (make-circular-list k . fill)\n"
    "  (%require-nonnegative-integer \"make-circular-list\" k)\n"
    "  (if (> (length fill) 1)\n"
    "      (error \"make-circular-list: too many arguments\"))\n"
    "  (if (= k 0)\n"
    "      '()\n"
    "      (apply circular-list\n"
    "             (make-list k (if (null? fill) #f (car fill))))))\n"
    "\n"
    "; xcons - like cons but with reversed arguments\n"
    "(define (xcons d a) (cons a d))\n"
    "\n"
    "; cons* - like list but last arg is tail\n"
    "(define (cons* first . rest)\n"
    "  (if (null? rest)\n"
    "      first\n"
    "      (cons first (apply cons* rest))))\n"
    "\n"
    "; make-list - create list of n elements, optionally filled with fill\n"
    "(define (make-list n . fill)\n"
    "  (%require-nonnegative-integer \"make-list\" n)\n"
    "  (if (> (length fill) 1)\n"
    "      (error \"make-list: too many arguments\"))\n"
    "  (let ((f (if (null? fill) #f (car fill))))\n"
    "    (let loop ((n n) (acc '()))\n"
    "      (if (<= n 0)\n"
    "          acc\n"
    "          (loop (- n 1) (cons f acc))))))\n"
    "\n"
    "; list-tabulate - create list by calling init-proc on indices 0..n-1\n"
    "(define (list-tabulate n init-proc)\n"
    "  (%require-nonnegative-integer \"list-tabulate\" n)\n"
    "  (let loop ((i (- n 1)) (acc '()))\n"
    "    (if (< i 0)\n"
    "        acc\n"
    "        (loop (- i 1) (cons (init-proc i) acc)))))\n"
    "\n"
    "; list-copy - shallow copy of list; R7RS explicitly documents this on\n"
    "; improper (dotted) lists too, preserving the non-null final cdr\n"
    "(define (list-copy lst)\n"
    "  (if (not (pair? lst))\n"
    "      lst\n"
    "      (begin\n"
    "        (%require-finite-list \"list-copy\" lst)\n"
    "        (let loop ((lst lst))\n"
    "          (if (pair? lst)\n"
    "              (cons (car lst) (loop (cdr lst)))\n"
    "              lst)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Predicates\n"
    ";;; ============================================================================\n"
    "\n"
    "; not-pair? - true if x is not a pair\n"
    "(define (not-pair? x) (not (pair? x)))\n"
    "\n"
    "; null-list? - like null? but signals error on improper list\n"
    "(define (null-list? lst)\n"
    "  (cond ((null? lst) #t)\n"
    "        ((pair? lst) #f)\n"
    "        (else (error \"null-list?: not a proper list\"))))\n"
    "\n"
    "; proper-list? - true if x is a proper list (finite, nil-terminated)\n"
    "; Uses tortoise-and-hare algorithm for cycle detection\n"
    "(define (proper-list? x)\n"
    "  (let loop ((fast x) (slow x) (first? #t))\n"
    "    (cond ((null? fast) #t)\n"
    "          ((not (pair? fast)) #f)\n"
    "          ((null? (cdr fast)) #t)\n"
    "          ((not (pair? (cdr fast))) #f)\n"
    "          ((and (not first?) (eq? fast slow)) #f)  ; cycle detected\n"
    "          (else (loop (cddr fast) (cdr slow) #f)))))\n"
    "\n"
    "; list? - alias for proper-list?\n"
    "(define list? proper-list?)\n"
    "\n"
    "; dotted-list? - true if x is a finite, non-nil-terminated list\n"
    "(define (dotted-list? x)\n"
    "  (let loop ((fast x) (slow x) (first? #t))\n"
    "    (cond ((null? fast) #f)\n"
    "          ((not (pair? fast)) #t)\n"
    "          ((null? (cdr fast)) #f)\n"
    "          ((not (pair? (cdr fast))) #t)\n"
    "          ((and (not first?) (eq? fast slow)) #f)  ; cycle - not dotted\n"
    "          (else (loop (cddr fast) (cdr slow) #f)))))\n"
    "\n"
    "; circular-list? - true only for a non-empty list whose cdr chain cycles.\n"
    "(define (circular-list? x)\n"
    "  (and (pair? x)\n"
    "       (not (proper-list? x))\n"
    "       (not (dotted-list? x))))\n"
    "\n"
    "; Reject unbounded all-circular traversals. A dotted input is permitted\n"
    "; when another list ends before its terminal atom is inspected; traversal\n"
    "; loops validate current pairs with null-list?, in argument order.\n"
    "(define (%require-circular-lists who lists)\n"
    "  (%require-proper-list who lists)\n"
    "  (if (null? lists)\n"
    "      (error (string-append who \": expected at least one list\")))\n"
    "  (let loop ((lists lists) (all-circular? #t))\n"
    "    (if (null? lists)\n"
    "        (if all-circular?\n"
    "            (error (string-append who\n"
    "                                  \": at least one list must be finite\"))\n"
    "            #t)\n"
    "        (let ((lst (car lists)))\n"
    "          (cond ((null? lst) #t)\n"
    "                ((not (pair? lst))\n"
    "                 (error (string-append who\n"
    "                                       \": expected list\")))\n"
    "                (else\n"
    "                 (loop (cdr lists)\n"
    "                       (and all-circular? (circular-list? lst)))))))))\n"
    "\n"
    "; length+ - length for a proper list, or #f for a circular list.\n"
    "(define (length+ x)\n"
    "  (cond ((proper-list? x) (length x))\n"
    "        ((circular-list? x) #f)\n"
    "        (else (error \"length+: expected proper or circular list\"))))\n"
    "\n"
    "; list= - compare lists element-wise using elt=\n"
    "(define (list= elt= . lists)\n"
    "  (or (null? lists)\n"
    "      (null? (cdr lists))\n"
    "      (let loop ((lists lists))\n"
    "        (or (null? (cdr lists))\n"
    "            (let ((a (car lists)) (b (cadr lists)))\n"
    "              (and (let cmp ((a a) (b b))\n"
    "                     (cond ((null-list? a) (null-list? b))\n"
    "                           ((null-list? b) #f)\n"
    "                           ((eq? a b) #t)\n"
    "                           ((elt= (car a) (car b))\n"
    "                            (cmp (cdr a) (cdr b)))\n"
    "                           (else #f)))\n"
    "                   (loop (cdr lists))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Selectors\n"
    ";;; ============================================================================\n"
    "\n"
    "; first through tenth - positional accessors\n"
    "(define (first x) (car x))\n"
    "(define (second x) (cadr x))\n"
    "(define (third x) (caddr x))\n"
    "(define (fourth x) (cadddr x))\n"
    "(define (fifth x) (car (cddddr x)))\n"
    "(define (sixth x) (cadr (cddddr x)))\n"
    "(define (seventh x) (caddr (cddddr x)))\n"
    "(define (eighth x) (cadddr (cddddr x)))\n"
    "(define (ninth x) (car (cddddr (cddddr x))))\n"
    "(define (tenth x) (cadr (cddddr (cddddr x))))\n"
    "\n"
    "; car+cdr - return both car and cdr as multiple values\n"
    "(define (car+cdr pair)\n"
    "  (values (car pair) (cdr pair)))\n"
    "\n"
    "; Count the pairs in a list-like object.  Unlike `length`, this accepts\n"
    "; dotted and circular lists; for a circular list, count each pair through\n"
    "; the first repeated pair exactly once.  Other objects count as zero.\n"
    "(define (count-pairs object)\n"
    "  (define (finite-count lst)\n"
    "    (let loop ((lst lst) (n 0))\n"
    "      (if (pair? lst)\n"
    "          (loop (cdr lst) (+ n 1))\n"
    "          n)))\n"
    "  (define (cycle-length entry)\n"
    "    (let loop ((lst (cdr entry)) (n 1))\n"
    "      (if (eq? lst entry)\n"
    "          n\n"
    "          (loop (cdr lst) (+ n 1)))))\n"
    "  (let detect ((slow object) (fast object))\n"
    "    (cond\n"
    "     ((not (pair? fast)) (finite-count object))\n"
    "     ((not (pair? (cdr fast))) (finite-count object))\n"
    "     (else\n"
    "      (let ((slow2 (cdr slow))\n"
    "            (fast2 (cdr (cdr fast))))\n"
    "        (if (eq? slow2 fast2)\n"
    "            (let find-entry ((a object) (b slow2) (prefix 0))\n"
    "              (if (eq? a b)\n"
    "                  (+ prefix (cycle-length a))\n"
    "                  (find-entry (cdr a) (cdr b) (+ prefix 1))))\n"
    "            (detect slow2 fast2)))))))\n"
    "\n"
    "; Internal users need the same cycle-safe semantics.\n"
    "(define (%pair-count lst)\n"
    "  (count-pairs lst))\n"
    "\n"
    "; take-right - return last n elements. SRFI-1/MIT permit a possibly\n"
    "; improper (dotted) list, returning the final non-nil cdr along with the\n"
    "; last n elements if n reaches all the way to it.\n"
    "(define (take-right lst n)\n"
    "  (%require-finite-list \"take-right\" lst)\n"
    "  (%require-nonnegative-integer \"take-right\" n)\n"
    "  (let ((len (%pair-count lst)))\n"
    "    (if (> n len)\n"
    "        (error \"take-right: list is shorter than requested count\")\n"
    "        (if (= n len)\n"
    "            lst\n"
    "            (drop lst (- len n))))))\n"
    "\n"
    "; drop-right - return all but last n elements\n"
    "(define (drop-right lst n)\n"
    "  (%require-finite-list \"drop-right\" lst)\n"
    "  (%require-nonnegative-integer \"drop-right\" n)\n"
    "  (let ((len (%pair-count lst)))\n"
    "    (if (> n len)\n"
    "        (error \"drop-right: list is shorter than requested count\")\n"
    "        (if (= n len)\n"
    "            '()\n"
    "            (take lst (- len n))))))\n"
    "\n"
    "; split-at - split list at index, return two lists\n"
    "(define (split-at lst n)\n"
    "  (%require-nonnegative-integer \"split-at\" n)\n"
    "  (values (take lst n) (drop lst n)))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Miscellaneous\n"
    ";;; ============================================================================\n"
    "\n"
    "; concatenate - append all lists in list-of-lists\n"
    "(define (concatenate lists)\n"
    "  (%require-proper-list \"concatenate\" lists)\n"
    "  (apply append lists))\n"
    "\n"
    "; append-reverse - (append (reverse rev-head) tail)\n"
    "(define (append-reverse rev-head tail)\n"
    "  (%require-proper-list \"append-reverse\" rev-head)\n"
    "  (let loop ((rev-head rev-head) (tail tail))\n"
    "    (if (null? rev-head)\n"
    "        tail\n"
    "        (loop (cdr rev-head) (cons (car rev-head) tail)))))\n"
    "\n"
    "; unzip1 - extract first elements from list of lists\n"
    "(define (unzip1 lists)\n"
    "  (%require-proper-list \"unzip1\" lists)\n"
    "  (map car lists))\n"
    "\n"
    "; unzip2 - extract first two elements from list of lists\n"
    "(define (unzip2 lists)\n"
    "  (%require-proper-list \"unzip2\" lists)\n"
    "  (values (map car lists) (map cadr lists)))\n"
    "\n"
    "; unzip3 - extract first three elements\n"
    "(define (unzip3 lists)\n"
    "  (%require-proper-list \"unzip3\" lists)\n"
    "  (values (map car lists) (map cadr lists) (map caddr lists)))\n"
    "\n"
    "; unzip4 - extract first four elements\n"
    "(define (unzip4 lists)\n"
    "  (%require-proper-list \"unzip4\" lists)\n"
    "  (values (map car lists) (map cadr lists) (map caddr lists) (map cadddr lists)))\n"
    "\n"
    "; unzip5 - extract first five elements\n"
    "(define (unzip5 lists)\n"
    "  (%require-proper-list \"unzip5\" lists)\n"
    "  (values (map car lists) (map cadr lists) (map caddr lists)\n"
    "          (map cadddr lists) (map fifth lists)))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Fold/Unfold/Map\n"
    ";;; ============================================================================\n"
    "\n"
    "; pair-fold - like fold but proc receives pairs, not elements.\n"
    "(define (pair-fold proc init lst . more-lists)\n"
    "  (if (null? lst)\n"
    "      init\n"
    "      (begin\n"
    "        (%require-circular-lists \"pair-fold\" (cons lst more-lists))\n"
    "        (let loop ((lists (cons lst more-lists)) (acc init))\n"
    "          (if (%search-list-end? lists)\n"
    "              acc\n"
    "              (let ((next (map cdr lists)))\n"
    "                (loop next (apply proc (append lists (list acc))))))))))\n"
    "\n"
    "; pair-fold-right - like fold-right but proc receives pairs.\n"
    "(define (pair-fold-right proc init lst . more-lists)\n"
    "  (if (null? lst)\n"
    "      init\n"
    "      (begin\n"
    "        (%require-circular-lists \"pair-fold-right\" (cons lst more-lists))\n"
    "        (let loop ((lists (cons lst more-lists)))\n"
    "          (if (%search-list-end? lists)\n"
    "              init\n"
    "              (apply proc\n"
    "                     (append lists\n"
    "                             (list (loop (map cdr lists))))))))))\n"
    "\n"
    "; reduce-right - like reduce but right-associative\n"
    "(define (reduce-right proc init lst)\n"
    "  (%require-proper-list \"reduce-right\" lst)\n"
    "  (if (null? lst)\n"
    "      init\n"
    "      (let loop ((rest lst))\n"
    "        (if (null? (cdr rest))\n"
    "            (car rest)\n"
    "            (proc (car rest) (loop (cdr rest)))))))\n"
    "\n"
    "; unfold - generate list from seed using p, f, g\n"
    "(define (unfold p f g seed . maybe-tail-gen)\n"
    "  (if (> (length maybe-tail-gen) 1)\n"
    "      (error \"unfold: too many arguments\"))\n"
    "  (let ((tail-gen (if (null? maybe-tail-gen)\n"
    "                      (lambda (x) '())\n"
    "                      (car maybe-tail-gen))))\n"
    "    (let loop ((seed seed))\n"
    "      (if (p seed)\n"
    "          (tail-gen seed)\n"
    "          (cons (f seed) (loop (g seed)))))))\n"
    "\n"
    "; unfold-right - like unfold but builds list right-to-left\n"
    "(define (unfold-right p f g seed . maybe-tail)\n"
    "  (if (> (length maybe-tail) 1)\n"
    "      (error \"unfold-right: too many arguments\"))\n"
    "  (let ((tail (if (null? maybe-tail) '() (car maybe-tail))))\n"
    "    (let loop ((seed seed) (acc tail))\n"
    "      (if (p seed)\n"
    "          acc\n"
    "          (loop (g seed) (cons (f seed) acc))))))\n"
    "\n"
    "; append-map - map then append results\n"
    "(define (append-map proc lst . lsts)\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-circular-lists \"append-map\" (cons lst lsts))\n"
    "        (apply append (apply map proc lst lsts)))))\n"
    "\n"
    "; append-map! - map then destructively append the resulting lists.\n"
    "(define (append-map! proc lst . lsts)\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-circular-lists \"append-map!\" (cons lst lsts))\n"
    "        (apply append! (apply map proc lst lsts)))))\n"
    "\n"
    "; filter-map - map and filter in one pass over one or more lists.\n"
    "(define (filter-map proc lst . more-lists)\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-circular-lists \"filter-map\" (cons lst more-lists))\n"
    "        (let loop ((lists (cons lst more-lists)) (acc '()))\n"
    "          (if (%search-list-end? lists)\n"
    "              (reverse acc)\n"
    "              (let ((result (apply proc (map car lists))))\n"
    "                (loop (map cdr lists)\n"
    "                      (if result (cons result acc) acc))))))))\n"
    "\n"
    "; pair-for-each - like for-each but proc receives pairs.  As with the other\n"
    "; SRFI-1 multi-list traversals, stop at the shortest list and permit circular\n"
    "; companions as long as at least one input list is finite.\n"
    "(define (pair-for-each proc lst . more-lists)\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-circular-lists \"pair-for-each\" (cons lst more-lists))\n"
    "        (let loop ((lists (cons lst more-lists)))\n"
    "          (if (not (%search-list-end? lists))\n"
    "              (let ((next (map cdr lists)))\n"
    "                ; Capture successors before the callback: SRFI-1 permits the\n"
    "                ; callback to mutate the pairs it receives, without changing\n"
    "                ; the sequence of pairs that pair-for-each visits.\n"
    "                (apply proc lists)\n"
    "                (loop next)))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Searching\n"
    ";;; ============================================================================\n"
    "\n"
    "; find-tail - return tail of list starting at first match\n"
    "(define (find-tail pred lst)\n"
    "  (let loop ((lst lst))\n"
    "    (cond ((null? lst) #f)\n"
    "          ((not (pair? lst)) (error \"find-tail: improper list\"))\n"
    "          ((pred (car lst)) lst)\n"
    "          (else (loop (cdr lst))))))\n"
    "\n"
    "; list-index - return index of first element satisfying pred\n"
    "(define (list-index pred lst)\n"
    "  (let loop ((lst lst) (i 0))\n"
    "    (cond ((null? lst) #f)\n"
    "          ((not (pair? lst)) (error \"list-index: improper list\"))\n"
    "          ((pred (car lst)) i)\n"
    "          (else (loop (cdr lst) (+ i 1))))))\n"
    "\n"
    "; take-while - return longest prefix satisfying pred\n"
    "(define (take-while pred lst)\n"
    "  (let loop ((lst lst))\n"
    "    (if (or (null? lst) (not (pred (car lst))))\n"
    "        '()\n"
    "        (cons (car lst) (loop (cdr lst))))))\n"
    "\n"
    "; drop-while - drop longest prefix satisfying pred\n"
    "(define (drop-while pred lst)\n"
    "  (let loop ((lst lst))\n"
    "    (cond ((null? lst) '())\n"
    "          ((pred (car lst)) (loop (cdr lst)))\n"
    "          (else lst))))\n"
    "\n"
    "; span - split at first element not satisfying pred\n"
    "(define (span pred lst)\n"
    "  ; A single search keeps the two results complementary even when pred has\n"
    "  ; state. Immutable accumulation also preserves earlier continuation returns.\n"
    "  (let loop ((rest lst) (prefix '()))\n"
    "    (if (or (null? rest) (not (pred (car rest))))\n"
    "        (values (reverse prefix) rest)\n"
    "        (loop (cdr rest) (cons (car rest) prefix)))))\n"
    "\n"
    "; break - split at first element satisfying pred\n"
    "(define (break pred lst)\n"
    "  (span (lambda (x) (not (pred x))) lst))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Deletion\n"
    ";;; ============================================================================\n"
    "\n"
    "; delete - remove all elements equal to x\n"
    "(define (delete x lst . maybe-eq)\n"
    "  (if (> (length maybe-eq) 1)\n"
    "      (error \"delete: too many arguments\"))\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (let ((eq (%require-procedure\n"
    "                 \"delete\"\n"
    "                 (if (null? maybe-eq) equal? (car maybe-eq)))))\n"
    "        (filter (lambda (y) (not (eq x y))) lst))))\n"
    "\n"
    "; delete-duplicates - remove duplicate elements\n"
    "(define (delete-duplicates lst . maybe-eq)\n"
    "  (if (> (length maybe-eq) 1)\n"
    "      (error \"delete-duplicates: too many arguments\"))\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-proper-list \"delete-duplicates\" lst)\n"
    "        (let ((eq (%require-procedure\n"
    "                   \"delete-duplicates\"\n"
    "                   (if (null? maybe-eq) equal? (car maybe-eq)))))\n"
    "          (let loop ((lst lst) (seen '()))\n"
    "            (cond ((null? lst) (reverse seen))\n"
    "                  ((any (lambda (y) (eq (car lst) y)) seen)\n"
    "                   (loop (cdr lst) seen))\n"
    "                  (else (loop (cdr lst) (cons (car lst) seen)))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional SRFI-1 Association Lists\n"
    ";;; ============================================================================\n"
    "\n"
    "; alist-cons - add entry to front of alist\n"
    "(define (alist-cons key datum alist)\n"
    "  (cons (cons key datum) alist))\n"
    "\n"
    "; alist-copy - shallow copy of alist\n"
    "(define (alist-copy alist)\n"
    "  (%require-proper-list \"alist-copy\" alist)\n"
    "  (map (lambda (pair) (cons (car pair) (cdr pair))) alist))\n"
    "\n"
    "; alist-delete - remove entries matching key\n"
    "(define (alist-delete key alist . maybe-eq)\n"
    "  (if (> (length maybe-eq) 1)\n"
    "      (error \"alist-delete: too many arguments\"))\n"
    "  (if (null? alist)\n"
    "      '()\n"
    "      (let ((eq (%require-procedure\n"
    "                 \"alist-delete\"\n"
    "                 (if (null? maybe-eq) equal? (car maybe-eq)))))\n"
    "        (filter (lambda (pair) (not (eq key (car pair)))) alist))))\n"
    "\n"
    ";;; SRFI-1 set operations on lists\n"
    "\n"
    "(define (%lset-member? elt lst elt=)\n"
    "  (let loop ((lst lst))\n"
    "    (cond ((null? lst) #f)\n"
    "          ((elt= (car lst) elt) #t)\n"
    "          (else (loop (cdr lst))))))\n"
    "\n"
    "(define (%lset-subset? left right elt=)\n"
    "  (let loop ((left left))\n"
    "    (or (null? left)\n"
    "        (and (%lset-member? (car left) right elt=)\n"
    "             (loop (cdr left))))))\n"
    "\n"
    "(define (%lset-require-lists who lists)\n"
    "  (%require-proper-list who lists)\n"
    "  (for-each (lambda (lst) (%require-proper-list who lst)) lists)\n"
    "  lists)\n"
    "\n"
    "(define (lset<= elt= . lists)\n"
    "  (%lset-require-lists \"lset<=\" lists)\n"
    "  (if (null? lists)\n"
    "      #t\n"
    "      (let loop ((lists lists))\n"
    "        (or (null? (cdr lists))\n"
    "            (and (%lset-subset? (car lists) (cadr lists) elt=)\n"
    "                 (loop (cdr lists)))))))\n"
    "\n"
    "(define (lset= elt= . lists)\n"
    "  (%lset-require-lists \"lset=\" lists)\n"
    "  (if (null? lists)\n"
    "      #t\n"
    "      (let loop ((lists lists))\n"
    "        (or (null? (cdr lists))\n"
    "            (and (%lset-subset? (car lists) (cadr lists) elt=)\n"
    "                 (%lset-subset? (cadr lists) (car lists) elt=)\n"
    "                 (loop (cdr lists)))))))\n"
    "\n"
    "(define (lset-adjoin elt= list . elts)\n"
    "  (%require-proper-list \"lset-adjoin\" list)\n"
    "  (let loop ((elts elts) (result list))\n"
    "    (if (null? elts)\n"
    "        result\n"
    "        (let ((elt (car elts)))\n"
    "          (loop (cdr elts)\n"
    "                (if (%lset-member? elt result elt=)\n"
    "                    result\n"
    "                    (cons elt result)))))))\n"
    "\n"
    "(define (%lset-union2 elt= first second)\n"
    "  (let loop ((rest second) (result (list-copy first)))\n"
    "    (if (null? rest)\n"
    "        result\n"
    "        (let ((elt (car rest)))\n"
    "          (loop (cdr rest)\n"
    "                (if (%lset-member? elt result elt=)\n"
    "                    result\n"
    "                    (cons elt result)))))))\n"
    "\n"
    "(define (lset-union elt= . lists)\n"
    "  (%lset-require-lists \"lset-union\" lists)\n"
    "  (if (null? lists)\n"
    "      '()\n"
    "      (let loop ((lists (cdr lists)) (result (list-copy (car lists))))\n"
    "        (if (null? lists)\n"
    "            result\n"
    "            (loop (cdr lists) (%lset-union2 elt= result (car lists)))))))\n"
    "\n"
    "(define (lset-intersection elt= first . rest)\n"
    "  (%require-proper-list \"lset-intersection\" first)\n"
    "  (%lset-require-lists \"lset-intersection\" rest)\n"
    "  (filter\n"
    "   (lambda (elt)\n"
    "     (let loop ((lists rest))\n"
    "       (or (null? lists)\n"
    "           (and (%lset-member? elt (car lists) elt=)\n"
    "                (loop (cdr lists))))))\n"
    "   first))\n"
    "\n"
    "(define (lset-difference elt= first . rest)\n"
    "  (%require-proper-list \"lset-difference\" first)\n"
    "  (%lset-require-lists \"lset-difference\" rest)\n"
    "  (filter\n"
    "   (lambda (elt)\n"
    "     (let loop ((lists rest))\n"
    "       (or (null? lists)\n"
    "           (and (not (%lset-member? elt (car lists) elt=))\n"
    "                (loop (cdr lists))))))\n"
    "   first))\n"
    "\n"
    "(define (lset-xor elt= . lists)\n"
    "  (%lset-require-lists \"lset-xor\" lists)\n"
    "  (let loop ((lists lists) (result '()))\n"
    "    (if (null? lists)\n"
    "        result\n"
    "        (if (null? result)\n"
    "            (loop (cdr lists) (list-copy (car lists)))\n"
    "            (let ((left (lset-difference elt= result (car lists)))\n"
    "                  (right (lset-difference elt= (car lists) result)))\n"
    "              (loop (cdr lists) (append (reverse left) right)))))))\n"
    "\n"
    "(define (lset-diff+intersection elt= first . rest)\n"
    "  (%require-proper-list \"lset-diff+intersection\" first)\n"
    "  (%lset-require-lists \"lset-diff+intersection\" rest)\n"
    "  (let ((others (apply lset-union elt= rest)))\n"
    "    (values (lset-difference elt= first others)\n"
    "            (lset-intersection elt= first others))))\n"
    "\n"
    "; SRFI-1 linear-update procedures are permitted to be pure implementations.\n"
    "(define lset-union! lset-union)\n"
    "(define lset-intersection! lset-intersection)\n"
    "(define lset-difference! lset-difference)\n"
    "(define lset-xor! lset-xor)\n"
    "(define lset-diff+intersection! lset-diff+intersection)\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; SRFI-1 Linear Update (Mutation) Procedures\n"
    ";;; ============================================================================\n"
    "\n"
    "; take! - destructive version of take\n"
    "(define (take! lst n)\n"
    "  (%require-nonnegative-integer \"take!\" n)\n"
    "  (cond ((= n 0) '())\n"
    "        (else\n"
    "         (let ((tail (drop lst (- n 1))))\n"
    "           (if (not (pair? tail))\n"
    "               (error \"take!: list is shorter than requested count\")\n"
    "               (begin\n"
    "                 (set-cdr! tail '())\n"
    "                 lst))))))\n"
    "\n"
    "; drop-right! - destructive version of drop-right\n"
    "(define (drop-right! lst n)\n"
    "  (%require-finite-list \"drop-right!\" lst)\n"
    "  (%require-nonnegative-integer \"drop-right!\" n)\n"
    "  (let ((len (%pair-count lst)))\n"
    "    (if (> n len)\n"
    "        (error \"drop-right!: list is shorter than requested count\")\n"
    "        (take! lst (- len n)))))\n"
    "\n"
    "; split-at! - destructive version of split-at\n"
    "(define (split-at! lst n)\n"
    "  (%require-nonnegative-integer \"split-at!\" n)\n"
    "  (if (= n 0)\n"
    "      (values '() lst)\n"
    "      (let ((tail (drop lst (- n 1))))\n"
    "        (if (not (pair? tail))\n"
    "            (error \"split-at!: list is shorter than requested count\")\n"
    "            (let ((rest (cdr tail)))\n"
    "              (set-cdr! tail '())\n"
    "              (values lst rest))))))\n"
    "\n"
    "; append! - destructive append. Every argument but the last must be a\n"
    "; finite list; a dotted prefix is permitted and its terminal tail is\n"
    "; replaced by the next argument, matching MIT's destructive behavior.  The\n"
    "; last argument may be any object.\n"
    "(define (append! . lists)\n"
    "  (if (pair? lists)\n"
    "      (let validate ((rest lists))\n"
    "        (if (pair? (cdr rest))\n"
    "            (begin\n"
    "              (%require-finite-list \"append!\" (car rest))\n"
    "              (validate (cdr rest)))))\n"
    "      lists)\n"
    "  (if (null? lists)\n"
    "      '()\n"
    "      (let loop ((result '()) (lists lists))\n"
    "        (cond ((null? lists) result)\n"
    "              ((null? (car lists)) (loop result (cdr lists)))\n"
    "              ((null? result) (loop (car lists) (cdr lists)))\n"
    "              (else\n"
    "               (let attach ((tail result))\n"
    "                 (if (pair? (cdr tail))\n"
    "                     (attach (cdr tail))\n"
    "                     (set-cdr! tail (car lists))))\n"
    "               (loop result (cdr lists)))))))\n"
    "\n"
    "; concatenate! - destructive concatenate\n"
    "(define (concatenate! list-of-lists)\n"
    "  (%require-proper-list \"concatenate!\" list-of-lists)\n"
    "  (apply append! list-of-lists))\n"
    "\n"
    "; reverse! - destructive reverse\n"
    "(define (reverse! lst)\n"
    "  (%require-proper-list \"reverse!\" lst)\n"
    "  (let loop ((prev '()) (curr lst))\n"
    "    (if (null? curr)\n"
    "        prev\n"
    "        (let ((next (cdr curr)))\n"
    "          (set-cdr! curr prev)\n"
    "          (loop curr next)))))\n"
    "\n"
    "; append-reverse! - destructive append-reverse\n"
    "(define (append-reverse! rev-head tail)\n"
    "  (%require-proper-list \"append-reverse!\" rev-head)\n"
    "  (let loop ((curr rev-head) (acc tail))\n"
    "    (if (null? curr)\n"
    "        acc\n"
    "        (let ((next (cdr curr)))\n"
    "          (set-cdr! curr acc)\n"
    "          (loop next curr)))))\n"
    "\n"
    "; map! - destructive map (mutates first list)\n"
    "(define (map! proc lst . lsts)\n"
    "  (if (null? lst)\n"
    "      lst\n"
    "      (begin\n"
    "        (%require-circular-lists \"map!\" (cons lst lsts))\n"
    "        (if (null? lsts)\n"
    "            ; Single list case\n"
    "            (let loop ((pair lst))\n"
    "              (if (null? pair)\n"
    "                  lst\n"
    "                  (begin\n"
    "                    (set-car! pair (proc (car pair)))\n"
    "                    (loop (cdr pair)))))\n"
    "            ; Multiple lists case\n"
    "            (begin\n"
    "              ; SRFI-1 requires every companion list to be at least as long\n"
    "              ; as the first list.  Validate this before changing the target\n"
    "              ; list; circular companions naturally satisfy the requirement.\n"
    "              (let validate ((pair lst) (others lsts))\n"
    "                (if (null? pair)\n"
    "                    #t\n"
    "                    (if (any null? others)\n"
    "                        (error \"map!: companion list is shorter than target\")\n"
    "                        (validate (cdr pair) (map cdr others)))))\n"
    "              (let loop ((pair lst) (others lsts))\n"
    "                (if (null? pair)\n"
    "                    lst\n"
    "                    (begin\n"
    "                      (set-car! pair (apply proc (car pair) (map car others)))\n"
    "                      (loop (cdr pair) (map cdr others))))))))))\n"
    "\n"
    "; filter! - destructive filter\n"
    "(define (filter! pred lst)\n"
    "  (%require-finite-list \"filter!\" lst)\n"
    "  ; Skip leading non-matching elements to find new head\n"
    "  (let find-head ((lst lst))\n"
    "    (cond ((null? lst) '())\n"
    "          ((pred (car lst))\n"
    "           ; Found head, now filter rest in place\n"
    "           (let loop ((prev lst) (curr (cdr lst)))\n"
    "             (cond ((not (pair? curr)) lst)\n"
    "                   ((pred (car curr))\n"
    "                    (loop curr (cdr curr)))\n"
    "                   (else\n"
    "                    (set-cdr! prev (cdr curr))\n"
    "                    (loop prev (cdr curr)))))\n"
    "           lst)\n"
    "          (else (find-head (cdr lst))))))\n"
    "\n"
    "; remove! - destructive remove\n"
    "(define (remove! pred lst)\n"
    "  (filter! (lambda (x) (not (pred x))) lst))\n"
    "\n"
    "; partition! - destructive partition\n"
    "(define (partition! pred lst)\n"
    "  (%require-finite-list \"partition!\" lst)\n"
    "  (if (and (not (null? lst)) (not (pair? lst)))\n"
    "      (error \"partition!: expected a list\"))\n"
    "  ; Classify each pair once. Separate filter/remove passes can disagree\n"
    "  ; when the predicate has state, duplicating or losing input elements.\n"
    "  (let ((yes (cons #f '())) (no (cons #f '())))\n"
    "    (let loop ((rest lst) (yes-tail yes) (no-tail no))\n"
    "      (if (not (pair? rest))\n"
    "          (begin\n"
    "            ; Preserve a dotted terminal tail in both results, as MIT does.\n"
    "            (set-cdr! yes-tail rest)\n"
    "            (set-cdr! no-tail rest)\n"
    "            (values (cdr yes) (cdr no)))\n"
    "          (let ((next (cdr rest)))\n"
    "            (if (pred (car rest))\n"
    "                (begin (set-cdr! yes-tail rest)\n"
    "                       (loop next rest no-tail))\n"
    "                (begin (set-cdr! no-tail rest)\n"
    "                       (loop next yes-tail rest))))))))\n"
    "\n"
    "; take-while! - destructive take-while\n"
    "(define (take-while! pred lst)\n"
    "  (if (or (null? lst) (not (pred (car lst))))\n"
    "      '()\n"
    "      (let loop ((prev lst) (curr (cdr lst)))\n"
    "        (cond ((not (pair? curr)) lst)\n"
    "              ((pred (car curr)) (loop curr (cdr curr)))\n"
    "              (else\n"
    "               (set-cdr! prev '())\n"
    "               lst)))))\n"
    "\n"
    "; span! - destructive span\n"
    "(define (span! pred lst)\n"
    "  (if (or (null? lst) (not (pred (car lst))))\n"
    "      (values '() lst)\n"
    "      (let loop ((prev lst) (curr (cdr lst)))\n"
    "        (cond ((null? curr) (values lst '()))\n"
    "              ((pred (car curr)) (loop curr (cdr curr)))\n"
    "              (else\n"
    "               (set-cdr! prev '())\n"
    "               (values lst curr))))))\n"
    "\n"
    "; break! - destructive break\n"
    "(define (break! pred lst)\n"
    "  (span! (lambda (x) (not (pred x))) lst))\n"
    "\n"
    "; delete! - destructive delete\n"
    "(define (delete! x lst . maybe-eq)\n"
    "  (if (> (length maybe-eq) 1)\n"
    "      (error \"delete!: too many arguments\"))\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (let ((eq (%require-procedure\n"
    "                 \"delete!\"\n"
    "                 (if (null? maybe-eq) equal? (car maybe-eq)))))\n"
    "        (filter! (lambda (y) (not (eq x y))) lst))))\n"
    "\n"
    "; delete-duplicates! - destructive delete-duplicates\n"
    "(define (delete-duplicates! lst . maybe-eq)\n"
    "  (if (> (length maybe-eq) 1)\n"
    "      (error \"delete-duplicates!: too many arguments\"))\n"
    "  (if (null? lst)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-proper-list \"delete-duplicates!\" lst)\n"
    "        (let ((eq (%require-procedure\n"
    "                   \"delete-duplicates!\"\n"
    "                   (if (null? maybe-eq) equal? (car maybe-eq)))))\n"
    "          (let loop ((curr lst))\n"
    "            (if (null? curr)\n"
    "                lst\n"
    "                (begin\n"
    "                  (set-cdr! curr (delete! (car curr) (cdr curr) eq))\n"
    "                  (loop (cdr curr)))))))))\n"
    "\n"
    "; alist-delete! - destructive alist-delete\n"
    "(define (alist-delete! key alist . maybe-eq)\n"
    "  (if (> (length maybe-eq) 1)\n"
    "      (error \"alist-delete!: too many arguments\"))\n"
    "  (if (null? alist)\n"
    "      '()\n"
    "      (begin\n"
    "        (%require-proper-list \"alist-delete!\" alist)\n"
    "        (let ((eq (%require-procedure\n"
    "                   \"alist-delete!\"\n"
    "                   (if (null? maybe-eq) equal? (car maybe-eq)))))\n"
    "          (filter! (lambda (pair) (not (eq key (car pair)))) alist)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Dynamic-wind (R5RS)\n"
    ";;; ============================================================================\n"
    "\n"
    "; Wind stack: list of (before . after) pairs\n"
    "(define *wind-stack* '())\n"
    "\n"
    "; Helper: execute wind thunks when jumping between continuation points.\n"
    "; `from`/`to` are wind-stacks (innermost frame at the head, see\n"
    "; *wind-stack* above), and any real common ancestor context corresponds to\n"
    "; a common TAIL of the two lists - so this is the classic \"find the\n"
    "; convergence point of two lists that may differ in length\" problem.\n"
    "; Popping one frame off *each* side per step (as a naive implementation\n"
    "; might) only finds that point when the lists happen to have equal\n"
    "; length; when they don't, the shorter side hits '() first and the\n"
    "; unequal-length remainder of the longer side gets misidentified as\n"
    "; divergent, spuriously unwinding/rewinding dynamic-wind frames that were\n"
    "; never actually left. Fix: first equalize lengths by consuming the\n"
    "; longer list's extra head frames (running their thunks - after-thunks\n"
    "; for `from`, before-thunks for `to`), then walk the equal-length\n"
    "; remainders together to find the true common tail.\n"
    "(define (do-wind from to)\n"
    "  (define (length-of lst)\n"
    "    (if (circular-list? lst)\n"
    "        (error \"dynamic-wind: circular wind stack\")\n"
    "        (let loop ((l lst) (n 0))\n"
    "          (if (null? l) n (loop (cdr l) (+ n 1))))))\n"
    "  ; Run after-thunks for the n innermost (head) frames of `from` that have\n"
    "  ; no counterpart in `to` because `to` is shorter. Innermost-first order\n"
    "  ; (head to tail) is correct for unwinding.\n"
    "  (define (unwind-extra from n)\n"
    "    (if (= n 0)\n"
    "        from\n"
    "        (begin\n"
    "          (set! *wind-stack* from)\n"
    "          ((cdar from))\n"
    "          (unwind-extra (cdr from) (- n 1)))))\n"
    "  ; Run before-thunks for the n innermost (head) frames of `to` that have\n"
    "  ; no counterpart in `from` because `from` is shorter. Must run\n"
    "  ; outermost-first (reverse of `to`'s head-to-tail order), so recurse\n"
    "  ; down to the equal-length point first and run each thunk as the\n"
    "  ; recursion returns.\n"
    "  (define (rewind-extra to n)\n"
    "    (if (= n 0)\n"
    "        to\n"
    "        (let ((rest (rewind-extra (cdr to) (- n 1))))\n"
    "          (set! *wind-stack* to)\n"
    "          ((caar to))\n"
    "          rest)))\n"
    "  ; `from`/`to` now have equal length. Find the common tail: unwind from's\n"
    "  ; divergent prefix innermost-first (before recursing), then rewind to's\n"
    "  ; divergent prefix outermost-first (after recursing).\n"
    "  (define (converge from to)\n"
    "    (if (eq? from to)\n"
    "        to\n"
    "        (begin\n"
    "          (set! *wind-stack* from)\n"
    "          ((cdar from))\n"
    "          (let ((common (converge (cdr from) (cdr to))))\n"
    "            (set! *wind-stack* to)\n"
    "            ((caar to))\n"
    "            common))))\n"
    "  (unless (eq? from to)\n"
    "    (let* ((from-len (length-of from))\n"
    "           (to-len (length-of to))\n"
    "           (from1 (if (> from-len to-len)\n"
    "                      (unwind-extra from (- from-len to-len))\n"
    "                      from))\n"
    "           (to1 (if (> to-len from-len)\n"
    "                    (rewind-extra to (- to-len from-len))\n"
    "                    to)))\n"
    "      (converge from1 to1)))\n"
    "  (set! *wind-stack* to))\n"
    "\n"
    "; exit runs dynamic-wind after-thunks before terminating (R7RS 6.11: exit\n"
    "; behaves like a non-local exit, so before/after thunks must run).\n"
    "; emergency-exit is the escape hatch that skips them.\n"
    "(define (exit . args)\n"
    "  (do-wind *wind-stack* '())\n"
    "  (if (null? args)\n"
    "      (primitive-exit 0)\n"
    "      (apply primitive-exit args)))\n"
    "\n"
    "; dynamic-wind: establish before/after thunks around body\n"
    "(define dynamic-wind\n"
    "  (lambda (before body after)\n"
    "    (before)\n"
    "    (set! *wind-stack* (cons (cons before after) *wind-stack*))\n"
    "    (call-with-values\n"
    "      body\n"
    "      (lambda results\n"
    "        (set! *wind-stack* (cdr *wind-stack*))\n"
    "        (after)\n"
    "        (apply values results)))))\n"
    "\n"
    "; Wrap call/cc to handle dynamic-wind\n"
    "(define call-with-current-continuation\n"
    "  (let ((primitive-call/cc call-with-current-continuation))\n"
    "    (lambda (proc)\n"
    "      (let ((winds *wind-stack*))\n"
    "        (primitive-call/cc\n"
    "         (lambda (cont)\n"
    "           (proc (lambda vals\n"
    "                   (do-wind *wind-stack* winds)\n"
    "                   (apply cont vals)))))))))\n"
    "\n"
    "(define call/cc call-with-current-continuation)\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; SRFI-39/R7RS parameters\n"
    ";;; ============================================================================\n"
    "\n"
    ";; Private sentinel: a second argument eq? to this tells the parameter\n"
    ";; procedure to store its first argument as-is, bypassing the converter.\n"
    ";; parameterize uses this to restore the old value on exit - that value is\n"
    ";; already-converted (it came from a previous call to the parameter), so\n"
    ";; running it through the converter again would apply it twice and corrupt\n"
    ";; state for any converter that isn't idempotent (R7RS 4.2.6: the dynamic\n"
    ";; extent's original value is restored, not reconverted).\n"
    "(define %parameter-raw-set-tag (list 'parameter-raw-set))\n"
    "(define %parameter-convert-tag (list 'parameter-convert))\n"
    "\n"
    "(define (%make-parameter-procedure getter setter converter)\n"
    "  (lambda args\n"
    "    (cond ((null? args)\n"
    "           (getter))\n"
    "          ((null? (cdr args))\n"
    "           (setter (converter (car args))))\n"
    "          ((and (null? (cddr args)) (eq? (cadr args) %parameter-raw-set-tag))\n"
    "           (setter (car args)))\n"
    "          ((and (null? (cddr args)) (eq? (cadr args) %parameter-convert-tag))\n"
    "           (converter (car args)))\n"
    "          (else\n"
    "           (error \"parameter: expected zero or one argument\")))))\n"
    "\n"
    "(define (make-parameter init . maybe-converter)\n"
    "  (if (> (length maybe-converter) 1)\n"
    "      (error \"make-parameter: too many arguments\"))\n"
    "  (let ((converter (if (null? maybe-converter)\n"
    "                       (lambda (x) x)\n"
    "                       (car maybe-converter)))\n"
    "        (cell (vector 'parameter #f)))\n"
    "    (vector-set! cell 1 (converter init))\n"
    "    (%make-parameter-procedure\n"
    "      (lambda () (vector-ref cell 1))\n"
    "      (lambda (value) (vector-set! cell 1 value))\n"
    "      converter)))\n"
    "\n"
    ";; Use the runtime's port cells so parameterize, the explicit setters, and\n"
    ";; primitive I/O all observe the same value. Validation must not change it.\n"
    "(define (%make-port-parameter getter setter port? name)\n"
    "  (%make-parameter-procedure getter setter\n"
    "    (lambda (value)\n"
    "      (if (port? value)\n"
    "          value\n"
    "          (error name \"invalid port\" value)))))\n"
    "\n"
    "(set! current-input-port\n"
    "  (%make-port-parameter current-input-port set-current-input-port!\n"
    "                        input-port? \"current-input-port\"))\n"
    "(set! current-output-port\n"
    "  (%make-port-parameter current-output-port set-current-output-port!\n"
    "                        output-port? \"current-output-port\"))\n"
    "(set! current-error-port\n"
    "  (%make-port-parameter current-error-port set-current-error-port!\n"
    "                        output-port? \"current-error-port\"))\n"
    "\n"
    "(define (%call-with-parameterization parameters vals thunk)\n"
    "  ; Evaluate and convert every value before changing the dynamic environment.\n"
    "  (let ((bindings (map (lambda (p val)\n"
    "                         (cons p (p val %parameter-convert-tag)))\n"
    "                       parameters vals)))\n"
    "    (let bind ((remaining bindings))\n"
    "      (if (null? remaining)\n"
    "          (thunk)\n"
    "          (let* ((binding (car remaining))\n"
    "                 (p (car binding))\n"
    "                 (value (cdr binding)))\n"
    "            ; Swapping preserves changes made inside the extent when a\n"
    "            ; continuation reenters it, without running the converter again.\n"
    "            (define (swap!)\n"
    "              (let ((previous (p)))\n"
    "                (p value %parameter-raw-set-tag)\n"
    "                (set! value previous)))\n"
    "            (dynamic-wind swap!\n"
    "                          (lambda () (bind (cdr remaining)))\n"
    "                          swap!))))))\n"
    "\n"
    "(define-syntax parameterize\n"
    "  (syntax-rules ()\n"
    "    ((parameterize () body ...)\n"
    "     (begin body ...))\n"
    "    ((parameterize ((param value) ...) body ...)\n"
    "     (%call-with-parameterization (list param ...) (list value ...)\n"
    "                                 (lambda () body ...)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; SRFI-9: Defining Record Types\n"
    ";;; ============================================================================\n"
    "\n"
    ";; define-record-type creates a new record type with:\n"
    ";; - A constructor procedure\n"
    ";; - A predicate to test for instances\n"
    ";; - Accessor and mutator procedures for each field\n"
    ";;\n"
    ";; Syntax:\n"
    ";; (define-record-type <type-name>\n"
    ";;   (<constructor-name> <field-name> ...)\n"
    ";;   <predicate-name>\n"
    ";;   (<field-name> <accessor-name>)\n"
    ";;   (<field-name> <accessor-name> <mutator-name>)\n"
    ";;   ...)\n"
    ";;\n"
    ";; Implementation uses vectors: #(<type-tag> <field1> <field2> ...)\n"
    "\n"
    "(define (record-constructor-field-ref field bindings)\n"
    "  (cond ((assq field bindings) => cdr)\n"
    "        (else #f)))\n"
    "\n"
    "(define (record-any pred lst)\n"
    "  (cond ((null? lst) #f)\n"
    "        ((pred (car lst)) #t)\n"
    "        (else (record-any pred (cdr lst)))))\n"
    "\n"
    "(define (record-duplicates? lst)\n"
    "  (cond ((null? lst) #f)\n"
    "        ((memq (car lst) (cdr lst)) #t)\n"
    "        (else (record-duplicates? (cdr lst)))))\n"
    "\n"
    "(define (record-field-spec-name spec)\n"
    "  (if (and (pair? spec) (symbol? (car spec)))\n"
    "      (car spec)\n"
    "      (error \"define-record-type: invalid field spec\" spec)))\n"
    "\n"
    "(define (record-field-spec-accessor spec)\n"
    "  (if (and (pair? spec) (pair? (cdr spec)) (symbol? (cadr spec))\n"
    "           (or (null? (cddr spec))\n"
    "               (and (pair? (cddr spec)) (null? (cdddr spec))\n"
    "                    (symbol? (caddr spec)))))\n"
    "      (cadr spec)\n"
    "      (error \"define-record-type: invalid field spec\" spec)))\n"
    "\n"
    "(define (record-field-spec-mutator spec)\n"
    "  (if (and (pair? spec) (pair? (cdr spec)) (pair? (cddr spec))\n"
    "           (null? (cdddr spec)) (symbol? (caddr spec)))\n"
    "      (caddr spec)\n"
    "      #f))\n"
    "\n"
    "(define (record-remove-false lst)\n"
    "  (cond ((null? lst) '())\n"
    "        ((car lst) (cons (car lst) (record-remove-false (cdr lst))))\n"
    "        (else (record-remove-false (cdr lst)))))\n"
    "\n"
    "(define (validate-record-type-spec type-name constructor-name constructor-fields\n"
    "                                   predicate-name field-specs)\n"
    "  (if (not (symbol? type-name))\n"
    "      (error \"define-record-type: type name must be a symbol\" type-name))\n"
    "  (if (not (symbol? constructor-name))\n"
    "      (error \"define-record-type: constructor name must be a symbol\" constructor-name))\n"
    "  (if (not (symbol? predicate-name))\n"
    "      (error \"define-record-type: predicate name must be a symbol\" predicate-name))\n"
    "  (if (record-any (lambda (field) (not (symbol? field))) constructor-fields)\n"
    "      (error \"define-record-type: constructor fields must be symbols\"\n"
    "             constructor-fields))\n"
    "  (if (record-duplicates? constructor-fields)\n"
    "      (error \"define-record-type: duplicate constructor field\"\n"
    "             constructor-fields))\n"
    "  (let ((field-names (map record-field-spec-name field-specs)))\n"
    "    (if (record-duplicates? field-names)\n"
    "        (error \"define-record-type: duplicate field name\" field-names))\n"
    "    (for-each\n"
    "     (lambda (field)\n"
    "       (if (not (memq field field-names))\n"
    "           (error \"define-record-type: constructor field is not a record field\"\n"
    "                  field)))\n"
    "     constructor-fields)\n"
    "    (let* ((accessors (map record-field-spec-accessor field-specs))\n"
    "           (mutators (record-remove-false\n"
    "                      (map record-field-spec-mutator field-specs)))\n"
    "           (bindings (append (list type-name constructor-name predicate-name)\n"
    "                             accessors\n"
    "                             mutators)))\n"
    "      (if (record-duplicates? bindings)\n"
    "          (error \"define-record-type: duplicate generated binding\" bindings))))\n"
    "  #t)\n"
    "\n"
    "(define-syntax define-record-type\n"
    "  (syntax-rules ()\n"
    "    ((define-record-type type-name\n"
    "       (constructor-name constructor-field ...)\n"
    "       predicate-name\n"
    "       field-spec ...)\n"
    "     (begin\n"
    "       (validate-record-type-spec 'type-name\n"
    "                                  'constructor-name\n"
    "                                  '(constructor-field ...)\n"
    "                                  'predicate-name\n"
    "                                  '(field-spec ...))\n"
    "       ;; The constructor closure itself is a unique, stable type tag.  Avoid\n"
    "       ;; an introduced top-level helper binding here: repeated macro uses\n"
    "       ;; would otherwise share that binding and overwrite an earlier tag.\n"
    "       (define-record-constructor constructor-name\n"
    "         (constructor-field ...)\n"
    "         field-spec ...)\n"
    "\n"
    "       ;; Predicate: checks if value is a vector with matching type tag\n"
    "       (define predicate-name\n"
    "         (let ((record-type-tag constructor-name))\n"
    "           (lambda (obj)\n"
    "             (and (vector? obj)\n"
    "                  (> (vector-length obj) 0)\n"
    "                  (eq? (vector-ref obj 0) record-type-tag)))))\n"
    "\n"
    "       ;; Generate field accessors and mutators\n"
    "       (define-record-fields type-name predicate-name 1 field-spec ...)))))\n"
    "\n"
    "(define-syntax define-record-constructor\n"
    "  (syntax-rules ()\n"
    "    ((define-record-constructor constructor-name\n"
    "       (constructor-field ...)\n"
    "       field-spec ...)\n"
    "     ;; The private self-binding remains the tag even if the public\n"
    "     ;; constructor name is rebound or is also a constructor field name.\n"
    "     (define constructor-name\n"
    "       (letrec ((construct\n"
    "                 (lambda (constructor-field ...)\n"
    "                   (list->vector\n"
    "                     (cons construct\n"
    "                           (define-record-constructor-values\n"
    "                             (list (cons 'constructor-field constructor-field) ...)\n"
    "                             field-spec ...))))))\n"
    "         construct)))))\n"
    "\n"
    "(define-syntax define-record-constructor-values\n"
    "  (syntax-rules ()\n"
    "    ((define-record-constructor-values bindings)\n"
    "     '())\n"
    "    ((define-record-constructor-values bindings\n"
    "       (field-name accessor-name)\n"
    "       rest ...)\n"
    "     (cons (record-constructor-field-ref 'field-name bindings)\n"
    "           (define-record-constructor-values bindings rest ...)))\n"
    "    ((define-record-constructor-values bindings\n"
    "       (field-name accessor-name mutator-name)\n"
    "       rest ...)\n"
    "     (cons (record-constructor-field-ref 'field-name bindings)\n"
    "           (define-record-constructor-values bindings rest ...)))))\n"
    "\n"
    ";; Helper macro to define field accessors/mutators\n"
    ";; Index starts at 1 because position 0 is the type tag\n"
    ";; Capture the predicate so rebinding its public name cannot change a field\n"
    ";; procedure's record type or bypass its type check.\n"
    "(define-syntax define-record-fields\n"
    "  (syntax-rules ()\n"
    "    ;; Base case: no more fields\n"
    "    ((define-record-fields type-name predicate-name index)\n"
    "     (begin))\n"
    "\n"
    "    ;; Field with accessor only\n"
    "    ((define-record-fields type-name predicate-name index\n"
    "       (field-name accessor-name)\n"
    "       rest ...)\n"
    "     (begin\n"
    "       (define accessor-name\n"
    "         (let ((record-predicate predicate-name))\n"
    "           (lambda (obj)\n"
    "             (if (record-predicate obj)\n"
    "                 (vector-ref obj index)\n"
    "                 (error \"record accessor: wrong record type\" obj)))))\n"
    "       (define-record-fields type-name predicate-name (+ index 1) rest ...)))\n"
    "\n"
    "    ;; Field with accessor and mutator\n"
    "    ((define-record-fields type-name predicate-name index\n"
    "       (field-name accessor-name mutator-name)\n"
    "       rest ...)\n"
    "     (begin\n"
    "       (define accessor-name\n"
    "         (let ((record-predicate predicate-name))\n"
    "           (lambda (obj)\n"
    "             (if (record-predicate obj)\n"
    "                 (vector-ref obj index)\n"
    "                 (error \"record accessor: wrong record type\" obj)))))\n"
    "       (define mutator-name\n"
    "         (let ((record-predicate predicate-name))\n"
    "           (lambda (obj val)\n"
    "             (if (record-predicate obj)\n"
    "                 (vector-set! obj index val)\n"
    "                 (error \"record mutator: wrong record type\" obj)))))\n"
    "       (define-record-fields type-name predicate-name (+ index 1) rest ...)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; SRFI-26: Notation for Specializing Parameters (cut/cute)\n"
    ";;; ============================================================================\n"
    "\n"
    ";; cut creates a procedure by specializing some parameters of another procedure.\n"
    ";; <> is a slot marker for parameters to be filled in later.\n"
    ";; <...> is a rest-slot marker for remaining arguments.\n"
    ";;\n"
    ";; Examples:\n"
    ";; (cut cons (+ a 1) <>)      => (lambda (x) (cons (+ a 1) x))\n"
    ";; (cut list 1 <> 3 <> 5)     => (lambda (x y) (list 1 x 3 y 5))\n"
    ";; (cut list 1 <> 3 <...>)    => (lambda (x . rest) (apply list 1 x 3 rest))\n"
    ";; (cut list)                 => (lambda () (list))\n"
    "\n"
    "(define-syntax cut\n"
    "  (syntax-rules (<> <...>)\n"
    "    ;; Entry point: start collecting\n"
    "    ((cut slot-or-expr ...)\n"
    "     (cut-helper () () (slot-or-expr ...)))))\n"
    "\n"
    "(define-syntax cut-helper\n"
    "  (syntax-rules (<> <...>)\n"
    "    ;; Base case: no more slots/exprs, no rest-slot\n"
    "    ((cut-helper (param ...) (arg ...) ())\n"
    "     (lambda (param ...) (arg ...)))\n"
    "\n"
    "    ;; Rest-slot at the end\n"
    "    ((cut-helper (param ...) (arg ...) (<...>))\n"
    "     (lambda (param ... . rest-args) (apply arg ... rest-args)))\n"
    "\n"
    "    ;; Slot: add a fresh parameter. Explicit states avoid reusing one\n"
    "    ;; introduced identifier for every <>.\n"
    "    ((cut-helper () (arg ...) (<> . rest))\n"
    "     (cut-helper (x1) (arg ... x1) rest))\n"
    "    ((cut-helper (x1) (arg ...) (<> . rest))\n"
    "     (cut-helper (x1 x2) (arg ... x2) rest))\n"
    "    ((cut-helper (x1 x2) (arg ...) (<> . rest))\n"
    "     (cut-helper (x1 x2 x3) (arg ... x3) rest))\n"
    "    ((cut-helper (x1 x2 x3) (arg ...) (<> . rest))\n"
    "     (cut-helper (x1 x2 x3 x4) (arg ... x4) rest))\n"
    "    ((cut-helper (x1 x2 x3 x4) (arg ...) (<> . rest))\n"
    "     (cut-helper (x1 x2 x3 x4 x5) (arg ... x5) rest))\n"
    "    ((cut-helper (x1 x2 x3 x4 x5) (arg ...) (<> . rest))\n"
    "     (cut-helper (x1 x2 x3 x4 x5 x6) (arg ... x6) rest))\n"
    "    ((cut-helper (x1 x2 x3 x4 x5 x6) (arg ...) (<> . rest))\n"
    "     (cut-helper (x1 x2 x3 x4 x5 x6 x7) (arg ... x7) rest))\n"
    "    ((cut-helper (x1 x2 x3 x4 x5 x6 x7) (arg ...) (<> . rest))\n"
    "     (cut-helper (x1 x2 x3 x4 x5 x6 x7 x8) (arg ... x8) rest))\n"
    "    ((cut-helper (x1 x2 x3 x4 x5 x6 x7 x8) (arg ...) (<> . rest))\n"
    "     (error \"cut: too many slots\"))\n"
    "\n"
    "    ;; Expression: evaluate and add to args\n"
    "    ((cut-helper (param ...) (arg ...) (expr . rest))\n"
    "     (cut-helper (param ...) (arg ... expr) rest))))\n"
    "\n"
    ";; cute is like cut but evaluates non-slot expressions at definition time\n"
    ";; (not at call time like cut does).\n"
    ";;\n"
    ";; Example:\n"
    ";; (cute cons (+ a 1) <>) evaluates (+ a 1) once when cute form is evaluated,\n"
    ";; while (cut cons (+ a 1) <>) evaluates it on each call.\n"
    "\n"
    "(define-syntax cute\n"
    "  (syntax-rules (<> <...>)\n"
    "    ;; Entry point: start collecting\n"
    "    ((cute slot-or-expr ...)\n"
    "     (cute-helper () () (slot-or-expr ...)))))\n"
    "\n"
    "(define-syntax cute-helper\n"
    "  (syntax-rules (<> <...>)\n"
    "    ;; Base case: no more slots/exprs, no rest-slot\n"
    "    ((cute-helper (param ...) (arg ...) ())\n"
    "     (lambda (param ...) (arg ...)))\n"
    "\n"
    "    ;; Rest-slot at the end\n"
    "    ((cute-helper (param ...) (arg ...) (<...>))\n"
    "     (lambda (param ... . rest-args) (apply arg ... rest-args)))\n"
    "\n"
    "    ;; Slot: add a fresh parameter. Explicit states avoid reusing one\n"
    "    ;; introduced identifier for every <>.\n"
    "    ((cute-helper () (arg ...) (<> . rest))\n"
    "     (cute-helper (x1) (arg ... x1) rest))\n"
    "    ((cute-helper (x1) (arg ...) (<> . rest))\n"
    "     (cute-helper (x1 x2) (arg ... x2) rest))\n"
    "    ((cute-helper (x1 x2) (arg ...) (<> . rest))\n"
    "     (cute-helper (x1 x2 x3) (arg ... x3) rest))\n"
    "    ((cute-helper (x1 x2 x3) (arg ...) (<> . rest))\n"
    "     (cute-helper (x1 x2 x3 x4) (arg ... x4) rest))\n"
    "    ((cute-helper (x1 x2 x3 x4) (arg ...) (<> . rest))\n"
    "     (cute-helper (x1 x2 x3 x4 x5) (arg ... x5) rest))\n"
    "    ((cute-helper (x1 x2 x3 x4 x5) (arg ...) (<> . rest))\n"
    "     (cute-helper (x1 x2 x3 x4 x5 x6) (arg ... x6) rest))\n"
    "    ((cute-helper (x1 x2 x3 x4 x5 x6) (arg ...) (<> . rest))\n"
    "     (cute-helper (x1 x2 x3 x4 x5 x6 x7) (arg ... x7) rest))\n"
    "    ((cute-helper (x1 x2 x3 x4 x5 x6 x7) (arg ...) (<> . rest))\n"
    "     (cute-helper (x1 x2 x3 x4 x5 x6 x7 x8) (arg ... x8) rest))\n"
    "    ((cute-helper (x1 x2 x3 x4 x5 x6 x7 x8) (arg ...) (<> . rest))\n"
    "     (error \"cute: too many slots\"))\n"
    "\n"
    "    ;; Expression: wrap in a let to evaluate once, using nested approach\n"
    "    ((cute-helper (param ...) (arg ...) (expr . rest))\n"
    "     (let ((tmp expr))\n"
    "       (cute-helper (param ...) (arg ... tmp) rest)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Sort Utilities\n"
    ";;; ============================================================================\n"
    "\n"
    "; Tail-recursive merge.  The natural (cons x (loop ...)) formulation recurses\n"
    "; once per merged element, so the final merge of a 100000-element sort blew\n"
    "; the VM call stack outright.  Accumulating reversed and unwinding at the end\n"
    "; runs in constant stack depth.  Taking from `right` only when it is strictly\n"
    "; less than `left` is what makes the sort stable; preserve that comparison.\n"
    "; Private: skips the argument validation, so merge-sort does not re-walk both\n"
    "; halves at every node of the merge tree (which was O(n log n) extra walks).\n"
    "; `unwind` is an internal define on purpose, and it is the faster choice, not\n"
    "; merely the tidier one: as a top-level helper it would be resolved through\n"
    "; the global frame - a ~950-entry alist - on every one of the ~2n calls\n"
    "; merge-sort makes, which measured 3.9s against 2.4s for a 30000-element sort.\n"
    "; The public append-reverse is not usable here either, since it would\n"
    "; revalidate a list this procedure just built itself, at every node.\n"
    "(define (%merge-nocheck less? left right)\n"
    "  (define (unwind acc tail)\n"
    "    (if (null? acc)\n"
    "        tail\n"
    "        (unwind (cdr acc) (cons (car acc) tail))))\n"
    "  (let loop ((left left) (right right) (acc '()))\n"
    "    (cond ((null? left) (unwind acc right))\n"
    "          ((null? right) (unwind acc left))\n"
    "          ((less? (car right) (car left))\n"
    "           (loop left (cdr right) (cons (car right) acc)))\n"
    "          (else\n"
    "           (loop (cdr left) right (cons (car left) acc))))))\n"
    "\n"
    "(define (merge less? left right)\n"
    "  (%require-proper-list \"merge\" left)\n"
    "  (%require-proper-list \"merge\" right)\n"
    "  (%merge-nocheck less? left right))\n"
    "\n"
    "(define (list-sort less? lst . maybe-key)\n"
    "  (if (not (procedure? less?))\n"
    "      (error \"list-sort: expected comparison procedure\"))\n"
    "  (%require-proper-list \"list-sort\" lst)\n"
    "  (if (> (length maybe-key) 1)\n"
    "      (error \"list-sort: too many arguments\"))\n"
    "  (let ((key (if (null? maybe-key) (lambda (x) x) (car maybe-key))))\n"
    "    (if (not (procedure? key))\n"
    "        (error \"list-sort: expected key procedure\"))\n"
    "    ; With no key argument the wrapper would be (less? (identity a)\n"
    "    ; (identity b)) - three procedure calls per comparison instead of one,\n"
    "    ; on the innermost loop of the sort. Use less? directly instead.\n"
    "    (let ((compare (if (null? maybe-key)\n"
    "                       less?\n"
    "                       (lambda (a b) (less? (key a) (key b))))))\n"
    "      (let sort-list ((xs lst))\n"
    "        ; (cdr (cdr fast)) rather than cddr: cddr is a Scheme-level define,\n"
    "        ; not a C primitive, so it costs a full non-inlinable call on every\n"
    "        ; step of this split.\n"
    "        (let split ((slow xs) (fast xs) (front '()))\n"
    "          (if (or (null? fast) (null? (cdr fast)))\n"
    "              (let ((left (reverse front))\n"
    "                    (right slow))\n"
    "                (cond ((null? right) left)\n"
    "                      ((null? (cdr right)) (%merge-nocheck compare left right))\n"
    "                      (else (%merge-nocheck compare\n"
    "                                            (sort-list left)\n"
    "                                            (sort-list right)))))\n"
    "              (split (cdr slow) (cdr (cdr fast))\n"
    "                     (cons (car slow) front))))))))\n"
    "\n"
    "(define (stable-sort sequence less? . maybe-key)\n"
    "  (if (> (length maybe-key) 1)\n"
    "      (error \"stable-sort: too many arguments\"))\n"
    "  (if (vector? sequence)\n"
    "      (list->vector (apply list-sort less? (vector->list sequence)\n"
    "                           maybe-key))\n"
    "      (apply list-sort less? sequence maybe-key)))\n"
    "\n"
    "(define sort stable-sort)\n"
    "\n"
    "(define (vector-sort less? vec . maybe-key)\n"
    "  (if (> (length maybe-key) 1)\n"
    "      (error \"vector-sort: too many arguments\"))\n"
    "  (list->vector (apply list-sort less? (vector->list vec) maybe-key)))\n"
    "\n"
    "(define (vector-sort! less? vec . maybe-key)\n"
    "  (if (> (length maybe-key) 1)\n"
    "      (error \"vector-sort!: too many arguments\"))\n"
    "  (let ((sorted (apply vector-sort less? vec maybe-key)))\n"
    "    (let loop ((i 0))\n"
    "      (if (< i (vector-length vec))\n"
    "          (begin\n"
    "            (vector-set! vec i (vector-ref sorted i))\n"
    "            (loop (+ i 1)))\n"
    "          vec))))\n"
    "\n"
    "(define (sort! sequence less? . maybe-key)\n"
    "  (if (> (length maybe-key) 1)\n"
    "      (error \"sort!: too many arguments\"))\n"
    "  (if (vector? sequence)\n"
    "      (apply vector-sort! less? sequence maybe-key)\n"
    "      (error \"sort!: expected vector\")))\n"
    "\n"
    ";;; ============================================================================\n"
    "; MIT-compatible names.  The stable merge-sort implementation is used for\n"
    "; both public non-destructive algorithms in this compact runtime.\n"
    "(define (merge-sort sequence less? . maybe-key)\n"
    "  (apply stable-sort sequence less? maybe-key))\n"
    "(define (quick-sort sequence less? . maybe-key)\n"
    "  (apply stable-sort sequence less? maybe-key))\n"
    "(define merge-sort! sort!)\n"
    "(define quick-sort! sort!)\n"
    "\n"
    ";;; Format (SRFI-28 basic format strings)\n"
    ";;; ============================================================================\n"
    "\n"
    ";; format - formatted output\n"
    ";; Supports: ~a, ~s, ~d, ~x, ~o, ~b, ~r, ~c, ~%, ~&, ~_\n"
    ";; First argument can be:\n"
    ";;   #f - return string\n"
    ";;   #t - output to current-output-port, return unspecified\n"
    ";;   port - output to port, return unspecified\n"
    "(define (format dest fmt . args)\n"
    "  (define (require-arg args directive)\n"
    "    (if (null? args)\n"
    "        (error (string-append \"format: not enough arguments for ~\" directive))\n"
    "        (car args)))\n"
    "\n"
    "  (define (format-radix args radix directive port)\n"
    "    (let ((arg (require-arg args directive)))\n"
    "      (display (number->string arg radix) port)\n"
    "      (cdr args)))\n"
    "\n"
    "  (define (format-to-string)\n"
    "    (let ((out (open-output-string)))\n"
    "      (format-to-port out)\n"
    "      (get-output-string out)))\n"
    "\n"
    "  ; Scan an optional decimal radix parameter between ~ and the directive\n"
    "  ; letter (e.g. ~16r), returning (values radix-or-#f index-after-digits).\n"
    "  (define (scan-radix-param i)\n"
    "    (let loop ((j i) (n #f))\n"
    "      (if (and (< j (string-length fmt)) (char-numeric? (string-ref fmt j)))\n"
    "          (loop (+ j 1)\n"
    "                (+ (* (or n 0) 10) (digit-value (string-ref fmt j))))\n"
    "          (values n j))))\n"
    "\n"
    "  (define (format-to-port port)\n"
    "    (let loop ((i 0) (args args))\n"
    "      (if (< i (string-length fmt))\n"
    "          (let ((c (string-ref fmt i)))\n"
    "            (if (char=? c #\\~)\n"
    "                (if (< (+ i 1) (string-length fmt))\n"
    "                    (call-with-values\n"
    "                      (lambda () (scan-radix-param (+ i 1)))\n"
    "                      (lambda (radix-param j)\n"
    "                        (if (>= j (string-length fmt))\n"
    "                            (error \"format: incomplete escape at end of string\")\n"
    "                            (let ((directive (string-ref fmt j))\n"
    "                                  (next (+ j 1)))\n"
    "                      (cond\n"
    "                        ((or (char=? directive #\\a) (char=? directive #\\A))\n"
    "                         (display (require-arg args \"a\") port)\n"
    "                         (loop next (cdr args)))\n"
    "                        ((or (char=? directive #\\s) (char=? directive #\\S))\n"
    "                         (write (require-arg args \"s\") port)\n"
    "                         (loop next (cdr args)))\n"
    "                        ((or (char=? directive #\\d) (char=? directive #\\D))\n"
    "                         (loop next (format-radix args 10 \"d\" port)))\n"
    "                        ((or (char=? directive #\\x) (char=? directive #\\X))\n"
    "                         (loop next (format-radix args 16 \"x\" port)))\n"
    "                        ((or (char=? directive #\\o) (char=? directive #\\O))\n"
    "                         (loop next (format-radix args 8 \"o\" port)))\n"
    "                        ((or (char=? directive #\\b) (char=? directive #\\B))\n"
    "                         (loop next (format-radix args 2 \"b\" port)))\n"
    "                        ((or (char=? directive #\\r) (char=? directive #\\R))\n"
    "                         ; ~NNr prints in radix NN (e.g. ~16r for hex);\n"
    "                         ; bare ~r defaults to radix 10, like ~d\n"
    "                         (loop next\n"
    "                               (format-radix args (or radix-param 10) \"r\"\n"
    "                                            port)))\n"
    "                        ((or (char=? directive #\\c) (char=? directive #\\C))\n"
    "                         (let ((arg (require-arg args \"c\")))\n"
    "                           (if (char? arg)\n"
    "                               (write-char arg port)\n"
    "                               (error \"format: ~c expects a character\"))\n"
    "                           (loop next (cdr args))))\n"
    "                        ((char=? directive #\\%)\n"
    "                         (newline port)\n"
    "                         (loop next args))\n"
    "                        ((char=? directive #\\&)\n"
    "                         (newline port)\n"
    "                         (loop next args))\n"
    "                        ((char=? directive #\\_)\n"
    "                         (write-char #\\space port)\n"
    "                         (loop next args))\n"
    "                        ((char=? directive #\\~)\n"
    "                         (write-char #\\~ port)\n"
    "                         (loop next args))\n"
    "                        (else\n"
    "                         (error \"format: unknown directive\" directive)))))))\n"
    "                    (error \"format: incomplete escape at end of string\"))\n"
    "                (begin\n"
    "                  (write-char c port)\n"
    "                  (loop (+ i 1) args))))\n"
    "          #t)))\n"
    "\n"
    "  (cond\n"
    "    ((eq? dest #f) (format-to-string))\n"
    "    ((eq? dest #t) (format-to-port (current-output-port)))\n"
    "    ((output-port? dest) (format-to-port dest))\n"
    "    (else (error \"format: invalid destination\" dest))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; String Utilities\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (unicode-char . codes)\n"
    "  (list->string (map integer->char codes)))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Character sets (MIT/GNU Scheme character-set operations)\n"
    ";;; ============================================================================\n"
    "\n"
    "; Character sets are represented as a tagged vector.  Finite sets built from\n"
    "; characters, strings, and ranges use a sorted, disjoint range list.  Unicode\n"
    "; property sets and set combinations use a predicate payload so construction\n"
    "; does not eagerly allocate a million-code-point table.\n"
    "(define %char-code-limit #x110000)\n"
    "\n"
    "(define (%make-char-set kind payload)\n"
    "  (vector 'char-set kind payload))\n"
    "\n"
    "(define (%char-set-range-well-formed? element)\n"
    "  (and (pair? element)\n"
    "       (not (pair? (cdr element)))\n"
    "       (integer? (car element))\n"
    "       (exact? (car element))\n"
    "       (integer? (cdr element))\n"
    "       (exact? (cdr element))\n"
    "       (>= (car element) 0)\n"
    "       (<= (car element) (cdr element))\n"
    "       (<= (cdr element) %char-code-limit)))\n"
    "\n"
    "(define (%char-set-ranges-well-formed? ranges)\n"
    "  (and (proper-list? ranges)\n"
    "       (let loop ((ranges ranges))\n"
    "         (or (null? ranges)\n"
    "             (and (%char-set-range-well-formed? (car ranges))\n"
    "                  (loop (cdr ranges)))))))\n"
    "\n"
    "(define (char-set? obj)\n"
    "  (and (vector? obj)\n"
    "       (= (vector-length obj) 3)\n"
    "       (eq? (vector-ref obj 0) 'char-set)\n"
    "       (cond\n"
    "         ((eq? (vector-ref obj 1) 'ranges)\n"
    "          (%char-set-ranges-well-formed? (vector-ref obj 2)))\n"
    "         ((eq? (vector-ref obj 1) 'predicate)\n"
    "          (procedure? (vector-ref obj 2)))\n"
    "         (else #f))))\n"
    "\n"
    "(define (%require-char-set who obj)\n"
    "  (if (char-set? obj)\n"
    "      obj\n"
    "      (error (string-append who \": expected character set\"))))\n"
    "\n"
    "(define (%char-set-range-insert ranges start end)\n"
    "  (if (= start end)\n"
    "      ranges\n"
    "      (if (null? ranges)\n"
    "          (list (cons start end))\n"
    "          (let ((range (car ranges)))\n"
    "            (cond\n"
    "              ((< end (car range))\n"
    "               (cons (cons start end) ranges))\n"
    "              ((> start (cdr range))\n"
    "               (cons range\n"
    "                     (%char-set-range-insert (cdr ranges) start end)))\n"
    "              (else\n"
    "               (%char-set-range-insert\n"
    "                (cdr ranges)\n"
    "                (min start (car range))\n"
    "                (max end (cdr range)))))))))\n"
    "\n"
    "(define (%char-set-range-element? code element)\n"
    "  (and (%char-set-range-well-formed? element)\n"
    "       (>= code (car element))\n"
    "       (< code (cdr element))))\n"
    "\n"
    "(define (%char-set-code-point->char code)\n"
    "  ; Vesper intentionally rejects surrogate characters in integer->char, so\n"
    "  ; property predicates treat those code points as absent rather than\n"
    "  ; attempting to construct an invalid character.\n"
    "  (if (or (and (>= code #xD800) (< code #xE000))\n"
    "          (>= code %char-code-limit))\n"
    "      #f\n"
    "      (integer->char code)))\n"
    "\n"
    "(define (%unicode-code-point? code)\n"
    "  (and (>= code 0)\n"
    "       (< code %char-code-limit)\n"
    "       (or (< code #xD800)\n"
    "           (>= code #xE000))\n"
    "       (%unicode-assigned? (integer->char code))))\n"
    "\n"
    "(define (%char-set-named-predicate name)\n"
    "  (cond\n"
    "    ((eq? name 'alphabetic)\n"
    "     (lambda (ch) (and ch (char-alphabetic? ch))))\n"
    "    ((eq? name 'alphanumeric)\n"
    "     (lambda (ch) (and ch (or (char-alphabetic? ch) (char-numeric? ch)))))\n"
    "    ((eq? name 'cased)\n"
    "     (lambda (ch) (and ch (or (char-upper-case? ch) (char-lower-case? ch)))))\n"
    "    ((eq? name 'lower-case)\n"
    "     (lambda (ch) (and ch (char-lower-case? ch))))\n"
    "    ((eq? name 'numeric)\n"
    "     (lambda (ch) (and ch (char-numeric? ch))))\n"
    "    ((eq? name 'upper-case)\n"
    "     (lambda (ch) (and ch (char-upper-case? ch))))\n"
    "    ((eq? name 'whitespace)\n"
    "     (lambda (ch) (and ch (char-whitespace? ch))))\n"
    "    ((eq? name 'unicode)\n"
    "     (lambda (ch)\n"
    "       (and ch (%unicode-code-point? (char->integer ch)))))\n"
    "    (else #f)))\n"
    "\n"
    "(define (%char-set-element-member? code element)\n"
    "  (cond\n"
    "    ((char? element) (= code (char->integer element)))\n"
    "    ((and (integer? element) (exact? element)\n"
    "          (>= element 0) (< element %char-code-limit))\n"
    "     (= code element))\n"
    "    ((string? element)\n"
    "     (let loop ((i 0))\n"
    "       (and (< i (string-length element))\n"
    "            (or (= code (char->integer (string-ref element i)))\n"
    "                (loop (+ i 1))))))\n"
    "    ((char-set? element) (code-point-in-set? code element))\n"
    "    ((and (pair? element) (not (pair? (cdr element))))\n"
    "     (%char-set-range-element? code element))\n"
    "    ((symbol? element)\n"
    "     (let ((pred (%char-set-named-predicate element)))\n"
    "       (and pred (pred (%char-set-code-point->char code)))))\n"
    "    (else #f)))\n"
    "\n"
    "(define (%char-set-finite-element-range element)\n"
    "  (cond\n"
    "    ((char? element)\n"
    "     (list (cons (char->integer element) (+ (char->integer element) 1))))\n"
    "    ((and (integer? element) (exact? element)\n"
    "          (>= element 0) (< element %char-code-limit))\n"
    "     (list (cons element (+ element 1))))\n"
    "    ((and (pair? element) (not (pair? (cdr element))))\n"
    "     (if (and (integer? (car element)) (exact? (car element))\n"
    "              (integer? (cdr element)) (exact? (cdr element))\n"
    "              (>= (car element) 0)\n"
    "              (<= (car element) (cdr element))\n"
    "              (<= (cdr element) %char-code-limit))\n"
    "         (list element)\n"
    "         (error \"char-set: invalid code-point range\")))\n"
    "    ((string? element)\n"
    "     (let loop ((i 0) (ranges '()))\n"
    "       (if (= i (string-length element))\n"
    "           ranges\n"
    "           (let ((code (char->integer (string-ref element i))))\n"
    "             (loop (+ i 1)\n"
    "                   (%char-set-range-insert ranges code (+ code 1)))))))\n"
    "    ((char-set? element)\n"
    "     (if (eq? (vector-ref element 1) 'ranges)\n"
    "         (vector-ref element 2)\n"
    "         #f))\n"
    "    (else #f)))\n"
    "\n"
    "(define (char-set . elements)\n"
    "  (for-each\n"
    "    (lambda (element)\n"
    "      (if (and (symbol? element)\n"
    "               (not (%char-set-named-predicate element)))\n"
    "          (error \"char-set: unknown character-set name\" element)))\n"
    "    elements)\n"
    "  (let has-predicate? ((xs elements))\n"
    "    (if (null? xs)\n"
    "        (let loop ((xs elements) (ranges '()))\n"
    "          (if (null? xs)\n"
    "              (%make-char-set 'ranges ranges)\n"
    "              (let add ((rs (%char-set-finite-element-range (car xs)))\n"
    "                        (out ranges))\n"
    "                (if (null? rs)\n"
    "                    (loop (cdr xs) out)\n"
    "                    (add (cdr rs)\n"
    "                         (%char-set-range-insert\n"
    "                          out (car (car rs)) (cdr (car rs))))))))\n"
    "        (if (or (symbol? (car xs))\n"
    "                (and (char-set? (car xs))\n"
    "                     (eq? (vector-ref (car xs) 1) 'predicate)))\n"
    "            (%make-char-set\n"
    "             'predicate\n"
    "             (lambda (code)\n"
    "               (let scan ((ys elements))\n"
    "                 (and (pair? ys)\n"
    "                      (or (%char-set-element-member? code (car ys))\n"
    "                          (scan (cdr ys)))))))\n"
    "            (has-predicate? (cdr xs))))))\n"
    "\n"
    "(define (char-set* elements)\n"
    "  (%require-proper-list \"char-set*\" elements)\n"
    "  (apply char-set elements))\n"
    "\n"
    "(define (code-point-in-set? code set)\n"
    "  (%require-char-set \"code-point-in-set?\" set)\n"
    "  (if (or (not (integer? code)) (not (exact? code))\n"
    "          (< code 0) (>= code %char-code-limit))\n"
    "      (error \"code-point-in-set?: expected Unicode code point\"))\n"
    "  (if (eq? (vector-ref set 1) 'predicate)\n"
    "      ((vector-ref set 2) code)\n"
    "      (let loop ((ranges (vector-ref set 2)))\n"
    "        (and (pair? ranges)\n"
    "             (let ((range (car ranges)))\n"
    "               (if (< code (car range))\n"
    "                   #f\n"
    "                   (or (< code (cdr range))\n"
    "                       (loop (cdr ranges)))))))))\n"
    "\n"
    "(define (char-in-set? char set)\n"
    "  (%require-char-set \"char-in-set?\" set)\n"
    "  (if (not (char? char))\n"
    "      (error \"char-in-set?: expected character\"))\n"
    "  (code-point-in-set? (char->integer char) set))\n"
    "\n"
    "(define (char-set-predicate set)\n"
    "  (%require-char-set \"char-set-predicate\" set)\n"
    "  (lambda (char)\n"
    "    (and (char? char) (char-in-set? char set))))\n"
    "\n"
    "(define (compute-char-set predicate)\n"
    "  (if (not (procedure? predicate))\n"
    "      (error \"compute-char-set: expected predicate\"))\n"
    "  (let loop ((code 0) (ranges '()) (start #f))\n"
    "    (if (= code %char-code-limit)\n"
    "        (let ((ranges (if start\n"
    "                          (%char-set-range-insert ranges start code)\n"
    "                          ranges)))\n"
    "          (%make-char-set 'ranges ranges))\n"
    "        (let ((char (%char-set-code-point->char code)))\n"
    "          (if (not char)\n"
    "              (if start\n"
    "                  (loop (+ code 1)\n"
    "                        (%char-set-range-insert ranges start code)\n"
    "                        #f)\n"
    "                  (loop (+ code 1) ranges #f))\n"
    "              (let ((member? (predicate char)))\n"
    "                (if member?\n"
    "                    (if start\n"
    "                        (loop (+ code 1) ranges start)\n"
    "                        (loop (+ code 1) ranges code))\n"
    "                    (if start\n"
    "                        (loop (+ code 1)\n"
    "                              (%char-set-range-insert ranges start code)\n"
    "                              #f)\n"
    "                        (loop (+ code 1) ranges #f)))))))))\n"
    "\n"
    "(define (char-set->code-points set)\n"
    "  (%require-char-set \"char-set->code-points\" set)\n"
    "  (if (eq? (vector-ref set 1) 'predicate)\n"
    "      (char-set->code-points\n"
    "       (compute-char-set (lambda (char) ((vector-ref set 2)\n"
    "                                         (char->integer char)))))\n"
    "      (let loop ((ranges (vector-ref set 2)) (out '()))\n"
    "        (if (null? ranges)\n"
    "            (reverse out)\n"
    "            (let ((range (car ranges)))\n"
    "              (loop (cdr ranges)\n"
    "                    (cons (if (= (+ (car range) 1) (cdr range))\n"
    "                              (car range)\n"
    "                              range)\n"
    "                          out)))))))\n"
    "\n"
    "(define (char-set=? . sets)\n"
    "  (if (null? sets)\n"
    "      #t\n"
    "      (let ((first (car sets)))\n"
    "        (%require-char-set \"char-set=?\" first)\n"
    "        (let loop ((rest (cdr sets)))\n"
    "          (if (null? rest)\n"
    "              #t\n"
    "              (let ((other (car rest)))\n"
    "                (%require-char-set \"char-set=?\" other)\n"
    "                (and (equal? (char-set->code-points first)\n"
    "                             (char-set->code-points other))\n"
    "                     (loop (cdr rest)))))))))\n"
    "\n"
    "(define (char-set-invert set)\n"
    "  (%require-char-set \"char-set-invert\" set)\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code) (not (code-point-in-set? code set)))))\n"
    "\n"
    "(define (char-set-union . sets)\n"
    "  (%require-proper-list \"char-set-union\" sets)\n"
    "  (if (null? sets)\n"
    "      char-set:empty\n"
    "      (begin\n"
    "        (for-each (lambda (set) (%require-char-set \"char-set-union\" set))\n"
    "                  sets)\n"
    "        (%make-char-set 'predicate\n"
    "                        (lambda (code)\n"
    "                          (any (lambda (set) (code-point-in-set? code set))\n"
    "                               sets))))))\n"
    "\n"
    "(define (char-set-intersection . sets)\n"
    "  (%require-proper-list \"char-set-intersection\" sets)\n"
    "  (if (null? sets)\n"
    "      char-set:full\n"
    "      (begin\n"
    "        (for-each (lambda (set) (%require-char-set \"char-set-intersection\" set))\n"
    "                  sets)\n"
    "        (%make-char-set 'predicate\n"
    "                        (lambda (code)\n"
    "                          (every (lambda (set) (code-point-in-set? code set))\n"
    "                                 sets))))))\n"
    "\n"
    "(define (char-set-difference first . rest)\n"
    "  (%require-char-set \"char-set-difference\" first)\n"
    "  (for-each (lambda (set) (%require-char-set \"char-set-difference\" set))\n"
    "            rest)\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (and (code-point-in-set? code first)\n"
    "                         (every (lambda (set)\n"
    "                                 (not (code-point-in-set? code set)))\n"
    "                                rest)))))\n"
    "\n"
    "(define (char-set-union* sets)\n"
    "  (%require-proper-list \"char-set-union*\" sets)\n"
    "  (apply char-set-union sets))\n"
    "\n"
    "(define (char-set-intersection* sets)\n"
    "  (%require-proper-list \"char-set-intersection*\" sets)\n"
    "  (apply char-set-intersection sets))\n"
    "\n"
    "(define char-set:empty (%make-char-set 'ranges '()))\n"
    "(define char-set:full\n"
    "  (%make-char-set 'predicate (lambda (code) #t)))\n"
    "\n"
    "(define char-set:alphabetic\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (let ((char (%char-set-code-point->char code)))\n"
    "                      (and char (char-alphabetic? char))))))\n"
    "(define char-set:numeric\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (let ((char (%char-set-code-point->char code)))\n"
    "                      (and char (char-numeric? char))))))\n"
    "(define char-set:whitespace\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (let ((char (%char-set-code-point->char code)))\n"
    "                      (and char (char-whitespace? char))))))\n"
    "(define char-set:not-whitespace\n"
    "  (char-set-difference char-set:full char-set:whitespace))\n"
    "(define char-set:upper-case\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (let ((char (%char-set-code-point->char code)))\n"
    "                      (and char (char-upper-case? char))))))\n"
    "(define char-set:lower-case\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (let ((char (%char-set-code-point->char code)))\n"
    "                      (and char (char-lower-case? char))))))\n"
    "(define char-set:alphanumeric\n"
    "  (char-set-union char-set:alphabetic char-set:numeric))\n"
    "\n"
    "; Additional SRFI-14 standard sets whose definitions are expressible using\n"
    "; the character predicates and scalar range supported by this runtime.\n"
    "(define char-set:letter char-set:alphabetic)\n"
    "(define char-set:digit char-set:numeric)\n"
    "(define char-set:letter+digit char-set:alphanumeric)\n"
    "(define char-set:ascii (char-set (cons 0 128)))\n"
    "(define char-set:blank (char-set #\\space #\\tab))\n"
    "(define char-set:hex-digit\n"
    "  (char-set \"0123456789abcdefABCDEF\"))\n"
    "\n"
    "; The remaining SRFI-14 standard sets.  The runtime does not expose the full\n"
    "; Unicode general-category table, so the sets whose definitions require those\n"
    "; categories use the portable ASCII/control definitions from SRFI-14 while\n"
    "; composing with the runtime's Unicode-aware base sets where available.\n"
    "(define char-set:title-case\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (if (memq code\n"
    "                             '(453 456 459 498\n"
    "                               8072 8073 8074 8075 8076 8077 8078 8079\n"
    "                               8088 8089 8090 8091 8092 8093 8094 8095\n"
    "                               8104 8105 8106 8107 8108 8109 8110 8111\n"
    "                               8124 8140 8188))\n"
    "                        #t\n"
    "                        #f))))\n"
    "(define char-set:punctuation\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (let ((char (%char-set-code-point->char code)))\n"
    "                      (and char (%unicode-punctuation? char))))))\n"
    "(define char-set:symbol\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (let ((char (%char-set-code-point->char code)))\n"
    "                      (and char (%unicode-symbol? char))))))\n"
    "(define char-set:graphic\n"
    "  (char-set-union char-set:letter char-set:digit\n"
    "                  char-set:punctuation char-set:symbol))\n"
    "(define char-set:printing\n"
    "  (char-set-union char-set:graphic char-set:whitespace))\n"
    "(define char-set:iso-control\n"
    "  (%make-char-set 'predicate\n"
    "                  (lambda (code)\n"
    "                    (or (< code 32)\n"
    "                        (and (>= code 127) (< code 160))))))\n"
    "\n"
    "(define (%char-set-next-code set code)\n"
    "  (if (eq? (vector-ref set 1) 'ranges)\n"
    "      (let loop ((ranges (vector-ref set 2)))\n"
    "        (if (null? ranges)\n"
    "            #f\n"
    "            (let ((range (car ranges)))\n"
    "              (if (>= code (cdr range))\n"
    "                  (loop (cdr ranges))\n"
    "                  (max code (car range))))))\n"
    "      (let loop ((code code))\n"
    "        (if (>= code %char-code-limit)\n"
    "            #f\n"
    "            (if (code-point-in-set? code set)\n"
    "                code\n"
    "                (loop (+ code 1)))))))\n"
    "\n"
    "(define (char-set-cursor set)\n"
    "  (%require-char-set \"char-set-cursor\" set)\n"
    "  (let ((code (%char-set-next-code set 0)))\n"
    "    (if code\n"
    "        (vector 'char-set-cursor set code)\n"
    "        (vector 'char-set-cursor-end set))))\n"
    "\n"
    "(define (end-of-char-set? cursor)\n"
    "  (and (vector? cursor)\n"
    "       (= (vector-length cursor) 2)\n"
    "       (eq? (vector-ref cursor 0) 'char-set-cursor-end)))\n"
    "\n"
    "(define (%require-char-set-cursor who cursor)\n"
    "  (if (or (not (vector? cursor))\n"
    "          (not (or (= (vector-length cursor) 2)\n"
    "                   (= (vector-length cursor) 3)))\n"
    "          (not (eq? (vector-ref cursor 0)\n"
    "                    (if (= (vector-length cursor) 2)\n"
    "                        'char-set-cursor-end\n"
    "                        'char-set-cursor))))\n"
    "      (error (string-append who \": expected character-set cursor\")))\n"
    "  cursor)\n"
    "\n"
    "(define (char-set-ref set cursor)\n"
    "  (%require-char-set \"char-set-ref\" set)\n"
    "  (%require-char-set-cursor \"char-set-ref\" cursor)\n"
    "  (if (end-of-char-set? cursor)\n"
    "      (error \"char-set-ref: cursor is at end of character set\"))\n"
    "  (if (not (eq? set (vector-ref cursor 1)))\n"
    "      (error \"char-set-ref: cursor belongs to another character set\"))\n"
    "  (integer->char (vector-ref cursor 2)))\n"
    "\n"
    "(define (char-set-cursor-next set cursor)\n"
    "  (%require-char-set \"char-set-cursor-next\" set)\n"
    "  (%require-char-set-cursor \"char-set-cursor-next\" cursor)\n"
    "  (if (end-of-char-set? cursor)\n"
    "      (error \"char-set-cursor-next: cursor is at end of character set\"))\n"
    "  (if (not (eq? set (vector-ref cursor 1)))\n"
    "      (error \"char-set-cursor-next: cursor belongs to another character set\"))\n"
    "  (let ((code (%char-set-next-code set (+ (vector-ref cursor 2) 1))))\n"
    "    (if code\n"
    "        (vector 'char-set-cursor set code)\n"
    "        (vector 'char-set-cursor-end set))))\n"
    "\n"
    "(define (char-set-fold kons knil set)\n"
    "  (%require-char-set \"char-set-fold\" set)\n"
    "  (let loop ((cursor (char-set-cursor set)) (result knil))\n"
    "    (if (end-of-char-set? cursor)\n"
    "        result\n"
    "        (begin\n"
    "          (if (not (procedure? kons))\n"
    "              (error \"char-set-fold: expected procedure\"))\n"
    "          (loop (char-set-cursor-next set cursor)\n"
    "                (kons (char-set-ref set cursor) result))))))\n"
    "\n"
    "(define (char-set-hash set . maybe-bound)\n"
    "  (%require-char-set \"char-set-hash\" set)\n"
    "  (if (> (length maybe-bound) 1)\n"
    "      (error \"char-set-hash: too many arguments\"))\n"
    "  (let ((bound (if (null? maybe-bound) #f (car maybe-bound))))\n"
    "    (if (and bound\n"
    "             (or (not (integer? bound)) (not (exact? bound)) (<= bound 0)))\n"
    "        (error \"char-set-hash: expected positive exact integer bound\"))\n"
    "    (let ((hash (char-set-fold (lambda (char value)\n"
    "                                 (modulo (+ (* value 33)\n"
    "                                            (char->integer char))\n"
    "                                         2147483647))\n"
    "                               0\n"
    "                               set)))\n"
    "      (if bound (modulo hash bound) hash))))\n"
    "\n"
    "(define (8-bit-char-set? set)\n"
    "  (%require-char-set \"8-bit-char-set?\" set)\n"
    "  (let loop ((ranges (char-set->code-points set)))\n"
    "    (if (null? ranges)\n"
    "        #t\n"
    "        (let ((range (car ranges)))\n"
    "          (if (and (integer? range) (>= range 256))\n"
    "              #f\n"
    "              (if (and (pair? range) (> (cdr range) 256))\n"
    "                  #f\n"
    "                  (loop (cdr ranges))))))))\n"
    "\n"
    ";;; SRFI-14 convenience and update operations.\n"
    "(define (->char-set object)\n"
    "  (cond ((char-set? object) object)\n"
    "        ((char? object) (char-set object))\n"
    "        ((string? object) (string->char-set object))\n"
    "        ((pair? object) (list->char-set object))\n"
    "        ((null? object) (char-set))\n"
    "        (else (error \"->char-set: unsupported object\" object))))\n"
    "\n"
    "(define (list->char-set chars . maybe-base)\n"
    "  (%require-proper-list \"list->char-set\" chars)\n"
    "  (if (> (length maybe-base) 1)\n"
    "      (error \"list->char-set: too many arguments\"))\n"
    "  (for-each (lambda (char)\n"
    "              (if (not (char? char))\n"
    "                  (error \"list->char-set: expected character\")))\n"
    "            chars)\n"
    "  (if (null? maybe-base)\n"
    "      (apply char-set chars)\n"
    "      (char-set-union (car maybe-base) (apply char-set chars))))\n"
    "\n"
    "(define (string->char-set string . maybe-base)\n"
    "  (if (not (string? string))\n"
    "      (error \"string->char-set: expected string\"))\n"
    "  (if (> (length maybe-base) 1)\n"
    "      (error \"string->char-set: too many arguments\"))\n"
    "  (if (null? maybe-base)\n"
    "      (apply char-set (string->list string))\n"
    "      (char-set-union (car maybe-base)\n"
    "                      (apply char-set (string->list string)))))\n"
    "\n"
    "(define (char-set->list set)\n"
    "  (%require-char-set \"char-set->list\" set)\n"
    "  (let expand ((ranges (char-set->code-points set)) (out '()))\n"
    "    (if (null? ranges)\n"
    "        (reverse out)\n"
    "        (let ((range (car ranges)))\n"
    "          (if (integer? range)\n"
    "              (expand (cdr ranges) (cons (integer->char range) out))\n"
    "              (let fill ((code (car range)) (out out))\n"
    "                (if (= code (cdr range))\n"
    "                    (expand (cdr ranges) out)\n"
    "                    (fill (+ code 1)\n"
    "                          (cons (integer->char code) out)))))))))\n"
    "\n"
    "(define (char-set->string set)\n"
    "  (list->string (char-set->list set)))\n"
    "\n"
    "(define (char-set-size set)\n"
    "  (%require-char-set \"char-set-size\" set)\n"
    "  (let count ((ranges (char-set->code-points set)) (n 0))\n"
    "    (if (null? ranges)\n"
    "        n\n"
    "        (let ((range (car ranges)))\n"
    "          (count (cdr ranges)\n"
    "                 (+ n (if (integer? range)\n"
    "                          1\n"
    "                          (- (cdr range) (car range)))))))))\n"
    "\n"
    "(define (char-set-count predicate set)\n"
    "  (%require-char-set \"char-set-count\" set)\n"
    "  (let loop ((chars (char-set->list set)) (n 0))\n"
    "    (if (null? chars)\n"
    "        n\n"
    "        (begin\n"
    "          (if (not (procedure? predicate))\n"
    "              (error \"char-set-count: expected predicate\"))\n"
    "          (loop (cdr chars)\n"
    "                (if (predicate (car chars)) (+ n 1) n))))))\n"
    "\n"
    "(define (char-set-every predicate set)\n"
    "  (%require-char-set \"char-set-every\" set)\n"
    "  (let loop ((chars (char-set->list set)))\n"
    "    (if (null? chars)\n"
    "        #t\n"
    "        (begin\n"
    "          (if (not (procedure? predicate))\n"
    "              (error \"char-set-every: expected predicate\"))\n"
    "          (and (predicate (car chars))\n"
    "               (loop (cdr chars)))))))\n"
    "\n"
    "(define (char-set-any predicate set)\n"
    "  (%require-char-set \"char-set-any\" set)\n"
    "  (let loop ((chars (char-set->list set)))\n"
    "    (if (null? chars)\n"
    "        #f\n"
    "        (begin\n"
    "          (if (not (procedure? predicate))\n"
    "              (error \"char-set-any: expected predicate\"))\n"
    "          (or (predicate (car chars))\n"
    "              (loop (cdr chars)))))))\n"
    "\n"
    "(define (char-set-copy set)\n"
    "  (%require-char-set \"char-set-copy\" set)\n"
    "  (%make-char-set (vector-ref set 1) (vector-ref set 2)))\n"
    "\n"
    "(define (char-set-for-each procedure set)\n"
    "  (%require-char-set \"char-set-for-each\" set)\n"
    "  (for-each procedure (char-set->list set)))\n"
    "\n"
    "(define (char-set-map procedure set)\n"
    "  (%require-char-set \"char-set-map\" set)\n"
    "  (list->char-set (map procedure (char-set->list set))))\n"
    "\n"
    "(define (char-set-unfold predicate mapper successor seed . maybe-base)\n"
    "  (if (or (not (procedure? predicate))\n"
    "          (not (procedure? mapper))\n"
    "          (not (procedure? successor)))\n"
    "      (error \"char-set-unfold: expected procedures\"))\n"
    "  (if (> (length maybe-base) 1)\n"
    "      (error \"char-set-unfold: too many arguments\"))\n"
    "  (let ((base (if (null? maybe-base)\n"
    "                  (char-set)\n"
    "                  (%require-char-set \"char-set-unfold\" (car maybe-base)))))\n"
    "    (let loop ((value seed) (set base))\n"
    "      (if (predicate value)\n"
    "          (char-set-copy set)\n"
    "          (loop (successor value)\n"
    "                (char-set-adjoin set (mapper value)))))))\n"
    "\n"
    "(define (char-set-filter predicate set . maybe-base)\n"
    "  (%require-char-set \"char-set-filter\" set)\n"
    "  (if (> (length maybe-base) 1)\n"
    "      (error \"char-set-filter: too many arguments\"))\n"
    "  (let ((base (if (null? maybe-base)\n"
    "                  (char-set)\n"
    "                  (%require-char-set \"char-set-filter\" (car maybe-base)))))\n"
    "    (char-set-union base\n"
    "                    (list->char-set\n"
    "                     (let loop ((chars (char-set->list set)) (out '()))\n"
    "                       (if (null? chars)\n"
    "                           (reverse out)\n"
    "                           (begin\n"
    "                             ; MIT permits an invalid predicate when the\n"
    "                             ; filtered set is empty, since it is never\n"
    "                             ; called.  Validate lazily at the first element.\n"
    "                             (if (not (procedure? predicate))\n"
    "                                 (error \"char-set-filter: expected predicate\"))\n"
    "                             (loop (cdr chars)\n"
    "                                   (if (predicate (car chars))\n"
    "                                       (cons (car chars) out)\n"
    "                                       out)))))))))\n"
    "\n"
    "(define (ucs-range->char-set lower upper . args)\n"
    "  (if (or (not (integer? lower)) (not (exact? lower)) (< lower 0)\n"
    "          (not (integer? upper)) (not (exact? upper)) (< upper lower))\n"
    "      (error \"ucs-range->char-set: invalid range\"))\n"
    "  (if (> (length args) 2)\n"
    "      (error \"ucs-range->char-set: too many arguments\"))\n"
    "  (let ((error? (if (null? args) #f (car args)))\n"
    "        (base (if (< (length args) 2)\n"
    "                  (char-set)\n"
    "                  (%require-char-set \"ucs-range->char-set\" (cadr args)))))\n"
    "    (if (not (boolean? error?))\n"
    "        (error \"ucs-range->char-set: expected boolean\"))\n"
    "    (if (and error?\n"
    "             (or (>= lower %char-code-limit)\n"
    "                 (> upper %char-code-limit)\n"
    "                 (and (< lower #xE000) (> upper #xD800))))\n"
    "        (error \"ucs-range->char-set: invalid Unicode code point\"))\n"
    "    ; Bounds above the Unicode limit are harmless when ERROR? is false, but\n"
    "    ; must not turn this into a loop over an arbitrary bignum-sized interval.\n"
    "    ; Scalar code points form at most two intervals here, split by UTF-16's\n"
    "    ; surrogate block, so construct those ranges directly.\n"
    "    (let* ((scan-upper (min upper %char-code-limit))\n"
    "           (first-upper (min scan-upper #xD800))\n"
    "           (second-lower (max lower #xE000))\n"
    "           (ranges (if (< lower first-upper)\n"
    "                       (%char-set-range-insert '() lower first-upper)\n"
    "                       '()))\n"
    "           (ranges (if (< second-lower scan-upper)\n"
    "                       (%char-set-range-insert ranges second-lower scan-upper)\n"
    "                       ranges)))\n"
    "      (if (null? (char-set->code-points base))\n"
    "          (%make-char-set 'ranges ranges)\n"
    "          (char-set-union base (%make-char-set 'ranges ranges))))))\n"
    "\n"
    "(define (char-set-adjoin set . chars)\n"
    "  (%require-char-set \"char-set-adjoin\" set)\n"
    "  (for-each (lambda (char)\n"
    "              (if (not (char? char))\n"
    "                  (error \"char-set-adjoin: expected character\")))\n"
    "            chars)\n"
    "  (if (eq? (vector-ref set 1) 'ranges)\n"
    "      (let loop ((chars chars) (ranges (vector-ref set 2)))\n"
    "        (if (null? chars)\n"
    "            (%make-char-set 'ranges ranges)\n"
    "            (let ((code (char->integer (car chars))))\n"
    "              (loop (cdr chars)\n"
    "                    (%char-set-range-insert ranges code (+ code 1))))))\n"
    "      (char-set-union set (apply char-set chars))))\n"
    "\n"
    "(define (char-set-delete set . chars)\n"
    "  (%require-char-set \"char-set-delete\" set)\n"
    "  (char-set-difference set (apply char-set chars)))\n"
    "\n"
    "(define (char-set-contains? set char)\n"
    "  (char-in-set? char set))\n"
    "\n"
    "(define char-set-complement char-set-invert)\n"
    "\n"
    "(define (char-set-xor . sets)\n"
    "  (if (null? sets)\n"
    "      char-set:empty\n"
    "      (begin\n"
    "        (for-each (lambda (set) (%require-char-set \"char-set-xor\" set)) sets)\n"
    "        (%make-char-set\n"
    "         'predicate\n"
    "         (lambda (code)\n"
    "           (let parity ((sets sets) (odd? #f))\n"
    "             (if (null? sets)\n"
    "                 odd?\n"
    "                 (parity (cdr sets)\n"
    "                         (if (code-point-in-set? code (car sets))\n"
    "                             (not odd?)\n"
    "                             odd?)))))))))\n"
    "\n"
    "(define (char-set<= . sets)\n"
    "  (if (< (length sets) 2)\n"
    "      #t\n"
    "      (begin\n"
    "        (for-each (lambda (set) (%require-char-set \"char-set<=\" set)) sets)\n"
    "        (let loop ((sets sets))\n"
    "          (or (null? (cdr sets))\n"
    "              (and (let ((left (car sets)) (right (cadr sets)))\n"
    "                     (char-set-every (lambda (char) (char-in-set? char right))\n"
    "                                     left))\n"
    "                   (loop (cdr sets))))))))\n"
    "\n"
    "(define (char-set= . sets)\n"
    "  (apply char-set=? sets))\n"
    "\n"
    "(define (char-set-diff+intersection first second . rest)\n"
    "  (%require-char-set \"char-set-diff+intersection\" first)\n"
    "  (%require-char-set \"char-set-diff+intersection\" second)\n"
    "  (for-each (lambda (set) (%require-char-set \"char-set-diff+intersection\" set))\n"
    "            rest)\n"
    "  (values (apply char-set-difference first second rest)\n"
    "          (apply char-set-intersection first (cons second rest))))\n"
    "\n"
    "; SRFI-14 linear-update operations may be pure in this representation.\n"
    "(define char-set-adjoin! char-set-adjoin)\n"
    "(define char-set-delete! char-set-delete)\n"
    "(define char-set-complement! char-set-complement)\n"
    "(define char-set-union! char-set-union)\n"
    "(define char-set-intersection! char-set-intersection)\n"
    "\n"
    "; SRFI-14 linear-update constructors are allowed to be pure.  Keep their\n"
    "; required base-set arguments explicit so arity errors remain visible.\n"
    "(define (list->char-set! chars base)\n"
    "  (list->char-set chars base))\n"
    "\n"
    "(define (string->char-set! string base)\n"
    "  (string->char-set string base))\n"
    "\n"
    "(define (char-set-filter! predicate set base)\n"
    "  (char-set-filter predicate set base))\n"
    "\n"
    "(define (char-set-unfold! predicate mapper successor seed base)\n"
    "  (char-set-unfold predicate mapper successor seed base))\n"
    "\n"
    "(define (ucs-range->char-set! lower upper error? base)\n"
    "  (ucs-range->char-set lower upper error? base))\n"
    "\n"
    "(define (char-set-difference! first . rest)\n"
    "  (apply char-set-difference first rest))\n"
    "\n"
    "(define (char-set-xor! . sets)\n"
    "  (apply char-set-xor sets))\n"
    "\n"
    "(define (char-set-diff+intersection! first second . rest)\n"
    "  (apply char-set-diff+intersection first second rest))\n"
    "\n"
    "(define (read-delimited-string set . maybe-port)\n"
    "  (%require-char-set \"read-delimited-string\" set)\n"
    "  (if (> (length maybe-port) 1)\n"
    "      (error \"read-delimited-string: too many arguments\"))\n"
    "  (let ((port (if (null? maybe-port)\n"
    "                  (current-input-port)\n"
    "                  (car maybe-port))))\n"
    "    (let loop ((chars '()))\n"
    "      (let ((char (peek-char port)))\n"
    "        (cond\n"
    "          ((eof-object? char)\n"
    "           (if (null? chars) char (list->string (reverse chars))))\n"
    "          ((char-in-set? char set)\n"
    "           (list->string (reverse chars)))\n"
    "          (else\n"
    "           (read-char port)\n"
    "           (loop (cons char chars))))))))\n"
    "\n"
    "; MIT/GNU Scheme historically accepted (read-string char-set [port]) in\n"
    "; addition to the standard count-based form.  Preserve both interfaces while\n"
    "; keeping the primitive implementation for the count-based operation.\n"
    "(define %read-string-primitive read-string)\n"
    "(define (read-string first . maybe-port)\n"
    "  (if (char-set? first)\n"
    "      (apply read-delimited-string first maybe-port)\n"
    "      (apply %read-string-primitive first maybe-port)))\n"
    "\n"
    "(define (discard-chars set . maybe-port)\n"
    "  (%require-char-set \"discard-chars\" set)\n"
    "  (if (> (length maybe-port) 1)\n"
    "      (error \"discard-chars: too many arguments\"))\n"
    "  (let ((port (if (null? maybe-port)\n"
    "                  (current-input-port)\n"
    "                  (car maybe-port))))\n"
    "    (let loop ()\n"
    "      (let ((char (peek-char port)))\n"
    "        (cond ((eof-object? char) #f)\n"
    "              ((char-in-set? char set) #f)\n"
    "              (else (read-char port) (loop)))))))\n"
    "\n"
    "(define (read-string! string . args)\n"
    "  (if (not (string? string))\n"
    "      (error \"read-string!: expected string\"))\n"
    "  (if (> (length args) 3)\n"
    "      (error \"read-string!: too many arguments\"))\n"
    "  (let* ((port (if (null? args) (current-input-port) (car args)))\n"
    "         (start (if (< (length args) 2) 0 (cadr args)))\n"
    "         (end (if (< (length args) 3) (string-length string) (caddr args))))\n"
    "    ; Validate the port even for an empty range.  Otherwise malformed or\n"
    "    ; binary ports are silently accepted when the loop has no characters to\n"
    "    ; read.\n"
    "    (if (not (input-port? port))\n"
    "        (error \"read-string!: expected input port\"))\n"
    "    (if (not (textual-port? port))\n"
    "        (error \"read-string!: expected textual input port\"))\n"
    "    (if (or (not (integer? start)) (not (exact? start)) (< start 0)\n"
    "            (not (integer? end)) (not (exact? end)) (< end start)\n"
    "            (> end (string-length string)))\n"
    "        (error \"read-string!: invalid string range\"))\n"
    "    (let loop ((index start))\n"
    "      (if (= index end)\n"
    "          (- index start)\n"
    "          (let ((char (read-char port)))\n"
    "            (if (eof-object? char)\n"
    "                (if (= index start)\n"
    "                    char\n"
    "                    (- index start))\n"
    "                (begin\n"
    "                  (string-set! string index char)\n"
    "                  (loop (+ index 1)))))))))\n"
    "\n"
    "(define (read-substring! string start end . maybe-port)\n"
    "  (if (> (length maybe-port) 1)\n"
    "      (error \"read-substring!: too many arguments\"))\n"
    "  (if (null? maybe-port)\n"
    "      (read-string! string (current-input-port) start end)\n"
    "      (read-string! string (car maybe-port) start end)))\n"
    "\n"
    "(define (string-normalized-nfd? s)\n"
    "  (string=? s (string-normalize-nfd s)))\n"
    "\n"
    "(define (string-normalized-nfc? s)\n"
    "  (string=? s (string-normalize-nfc s)))\n"
    "\n"
    "(define (string-normalized-nfkd? s)\n"
    "  (string=? s (string-normalize-nfkd s)))\n"
    "\n"
    "(define (string-normalized-nfkc? s)\n"
    "  (string=? s (string-normalize-nfkc s)))\n"
    "\n"
    ";; MIT Scheme normalization names.\n"
    "(define string->nfd string-normalize-nfd)\n"
    "(define string->nfc string-normalize-nfc)\n"
    "(define string->nfkd string-normalize-nfkd)\n"
    "(define string->nfkc string-normalize-nfkc)\n"
    "(define string-in-nfd? string-normalized-nfd?)\n"
    "(define string-in-nfc? string-normalized-nfc?)\n"
    "\n"
    ";; string-prefix? - check if s starts with prefix\n"
    "(define (string-prefix? prefix s)\n"
    "  (let ((plen (string-length prefix))\n"
    "        (slen (string-length s)))\n"
    "    (and (>= slen plen)\n"
    "         (string=? prefix (substring s 0 plen)))))\n"
    "\n"
    ";; string-suffix? - check if s ends with suffix\n"
    "(define (string-suffix? suffix s)\n"
    "  (let ((xlen (string-length suffix))\n"
    "        (slen (string-length s)))\n"
    "    (and (>= slen xlen)\n"
    "         (string=? suffix (substring s (- slen xlen) slen)))))\n"
    "\n"
    "(define (string-prefix-ci? prefix s)\n"
    "  (string-prefix? (string-foldcase prefix) (string-foldcase s)))\n"
    "\n"
    "(define (string-suffix-ci? suffix s)\n"
    "  (string-suffix? (string-foldcase suffix) (string-foldcase s)))\n"
    "\n"
    ";; string-trim and friends retain characters in the optional character set.\n"
    ";; The default retains every non-whitespace character, matching MIT Scheme.\n"
    "(define (string-trim s . maybe-set)\n"
    "  (if (> (length maybe-set) 1)\n"
    "      (error \"string-trim: expected at most one character set\"))\n"
    "  (let ((set (if (null? maybe-set) char-set:not-whitespace (car maybe-set))))\n"
    "    (%require-char-set \"string-trim\" set)\n"
    "    ((string-trimmer 'to-trim\n"
    "                     (lambda (ch) (not (char-in-set? ch set)))) s)))\n"
    "\n"
    ";; string-trim-left - remove leading whitespace\n"
    "(define (string-trim-left s . maybe-set)\n"
    "  (if (> (length maybe-set) 1)\n"
    "      (error \"string-trim-left: expected at most one character set\"))\n"
    "  (let ((set (if (null? maybe-set) char-set:not-whitespace (car maybe-set))))\n"
    "    (%require-char-set \"string-trim-left\" set)\n"
    "    ((string-trimmer 'where 'leading\n"
    "                     'to-trim\n"
    "                     (lambda (ch) (not (char-in-set? ch set)))) s)))\n"
    "\n"
    ";; string-trim-right - remove trailing whitespace\n"
    "(define (string-trim-right s . maybe-set)\n"
    "  (if (> (length maybe-set) 1)\n"
    "      (error \"string-trim-right: expected at most one character set\"))\n"
    "  (let ((set (if (null? maybe-set) char-set:not-whitespace (car maybe-set))))\n"
    "    (%require-char-set \"string-trim-right\" set)\n"
    "    ((string-trimmer 'where 'trailing\n"
    "                     'to-trim\n"
    "                     (lambda (ch) (not (char-in-set? ch set)))) s)))\n"
    "\n"
    ";; string-split - split string by delimiter (default: whitespace)\n"
    "(define (string-split s . args)\n"
    "  (if (> (length args) 1)\n"
    "      (error \"string-split: expected at most one delimiter\"))\n"
    "  (let ((delim (if (null? args) #f (car args))))\n"
    "    ; The omitted delimiter selects whitespace splitting.  An explicitly\n"
    "    ; supplied delimiter must still be a character, even when the input is\n"
    "    ; empty (otherwise invalid arguments are silently accepted).\n"
    "    (if (and (pair? args) (not (char? delim)))\n"
    "        (error \"string-split: delimiter must be a character\"))\n"
    "    (if delim\n"
    "        ;; Split by specific character\n"
    "        (let loop ((i 0) (start 0) (result '()))\n"
    "          (if (>= i (string-length s))\n"
    "              (reverse (if (> i start)\n"
    "                           (cons (substring s start i) result)\n"
    "                           result))\n"
    "              (if (char=? (string-ref s i) delim)\n"
    "                  (loop (+ i 1) (+ i 1)\n"
    "                        (if (> i start)\n"
    "                            (cons (substring s start i) result)\n"
    "                            result))\n"
    "                  (loop (+ i 1) start result))))\n"
    "        ;; Split by whitespace\n"
    "        (let loop ((i 0) (start #f) (result '()))\n"
    "          (if (>= i (string-length s))\n"
    "              (reverse (if start\n"
    "                           (cons (substring s start i) result)\n"
    "                           result))\n"
    "              (let ((c (string-ref s i)))\n"
    "                (if (char-whitespace? c)\n"
    "                    (loop (+ i 1) #f\n"
    "                          (if start\n"
    "                              (cons (substring s start i) result)\n"
    "                              result))\n"
    "                    (loop (+ i 1) (or start i) result))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; SRFI-8: receive (binding to multiple values)\n"
    ";;; ============================================================================\n"
    "\n"
    ";; (receive (var ...) producer body ...)\n"
    ";; Binds vars to values returned by producer, then evaluates body\n"
    "(define-syntax receive\n"
    "  (syntax-rules ()\n"
    "    ((receive formals expression body ...)\n"
    "     (call-with-values (lambda () expression)\n"
    "       (lambda formals body ...)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; R7RS multiple-value binding forms\n"
    ";;; ============================================================================\n"
    "\n"
    ";; A multi-value <formals> is the same grammar as a lambda's parameter list:\n"
    ";; (var ...), a bare identifier (collects all values as a list), or a\n"
    ";; dotted (var ... . rest). %define-values-declare!/define-values-set!\n"
    ";; recurse on it the same way a variadic lambda would - matching (var . more)\n"
    ";; first (a pair, whether the overall shape is proper or dotted) and falling\n"
    ";; back to a bare identifier only once that no longer matches.\n"
    "(define-syntax %define-values-declare!\n"
    "  (syntax-rules ()\n"
    "    ((%define-values-declare! ()) '())\n"
    "    ((%define-values-declare! (var . more))\n"
    "     (begin (define var #f) (%define-values-declare! more)))\n"
    "    ((%define-values-declare! var) (define var #f))))\n"
    "\n"
    "(define-syntax define-values-set!\n"
    "  (syntax-rules ()\n"
    "    ((define-values-set! () vals)\n"
    "     (if (null? vals)\n"
    "         '()\n"
    "         (error \"define-values: too many values\")))\n"
    "    ((define-values-set! (var . more) vals)\n"
    "     (if (pair? vals)\n"
    "         (begin\n"
    "           (set! var (car vals))\n"
    "           (define-values-set! more (cdr vals)))\n"
    "         (error \"define-values: too few values\")))\n"
    "    ((define-values-set! var vals)\n"
    "     (set! var vals))))\n"
    "\n"
    "(define-syntax define-values\n"
    "  (syntax-rules ()\n"
    "    ((define-values formals expression)\n"
    "     (begin\n"
    "       (%define-values-declare! formals)\n"
    "       (let ((vals (call-with-values (lambda () expression) list)))\n"
    "         (define-values-set! formals vals))))))\n"
    "\n"
    "(define-syntax let-values-bind\n"
    "  (syntax-rules ()\n"
    "    ((let-values-bind () body ...)\n"
    "     (let () body ...))\n"
    "    ((let-values-bind ((vals formals) rest ...) body ...)\n"
    "     (call-with-values\n"
    "       (lambda () (apply values vals))\n"
    "       (lambda formals\n"
    "         (let-values-bind (rest ...) body ...))))))\n"
    "\n"
    ";; Evaluate every producer before introducing any of the bound variables.\n"
    ";; A direct ellipsis expansion using one identifier such as `vals` creates\n"
    ";; duplicate lambda formals for two or more clauses.  Store all producers as\n"
    ";; closures first; each closure captures the outer lexical environment, so\n"
    ";; evaluating them later still has parallel (not let*-values) visibility.\n"
    "(define-syntax let-values-bind-from-producers\n"
    "  (syntax-rules ()\n"
    "    ((let-values-bind-from-producers () producers body ...)\n"
    "     (begin body ...))\n"
    "    ((let-values-bind-from-producers ((formals ignored) rest ...)\n"
    "                                      producers body ...)\n"
    "     (call-with-values\n"
    "       (car producers)\n"
    "       (lambda formals\n"
    "         (let-values-bind-from-producers (rest ...) (cdr producers) body ...))))))\n"
    "\n"
    "(define-syntax let-values\n"
    "  (syntax-rules ()\n"
    "    ((let-values ((formals expression) ...) body ...)\n"
    "     (let ((producers (list (lambda () expression) ...)))\n"
    "       (let-values-bind-from-producers ((formals expression) ...)\n"
    "                                        producers body ...)))))\n"
    "\n"
    "(define-syntax let*-values\n"
    "  (syntax-rules ()\n"
    "    ((let*-values () body ...)\n"
    "     (let () body ...))\n"
    "    ((let*-values ((formals expression) rest ...) body ...)\n"
    "     (call-with-values\n"
    "       (lambda () expression)\n"
    "       (lambda formals\n"
    "         (let*-values (rest ...) body ...))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; R7RS case-lambda\n"
    ";;; ============================================================================\n"
    "\n"
    "(define-syntax case-lambda\n"
    "  (syntax-rules ()\n"
    "    ((case-lambda clause ...)\n"
    "     (lambda args\n"
    "       (case-lambda-dispatch\n"
    "         args\n"
    "         (list (case-lambda-clause clause) ...))))))\n"
    "\n"
    "(define-syntax case-lambda-clause\n"
    "  (syntax-rules ()\n"
    "    ((case-lambda-clause (formals body ...))\n"
    "     (cons 'formals (lambda formals body ...)))))\n"
    "\n"
    "(define (case-lambda-formals-match? formals argc)\n"
    "  (let loop ((xs formals) (n argc))\n"
    "    (cond\n"
    "      ((symbol? xs) #t)\n"
    "      ((null? xs) (= n 0))\n"
    "      ((pair? xs) (and (> n 0) (loop (cdr xs) (- n 1))))\n"
    "      (else #f))))\n"
    "\n"
    "(define (case-lambda-dispatch args clauses)\n"
    "  (let ((argc (length args)))\n"
    "    (let loop ((xs clauses))\n"
    "      (if (null? xs)\n"
    "          (error \"case-lambda: no matching clause\")\n"
    "          (let ((clause (car xs)))\n"
    "            (if (case-lambda-formals-match? (car clause) argc)\n"
    "                (apply (cdr clause) args)\n"
    "                (loop (cdr xs))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Hash-table utilities\n"
    ";;; ============================================================================\n"
    "\n"
    "(define %hash-table-ref-primitive hash-table-ref)\n"
    "\n"
    "(define (hash-table-ref table key . maybe-get-default)\n"
    "  (if (> (length maybe-get-default) 1)\n"
    "      (error \"hash-table-ref: too many arguments\"))\n"
    "  (if (hash-table-exists? table key)\n"
    "      (%hash-table-ref-primitive table key)\n"
    "      (if (null? maybe-get-default)\n"
    "          (%hash-table-ref-primitive table key)\n"
    "          ((car maybe-get-default)))))\n"
    "\n"
    "(define (alist->hash-table alist . args)\n"
    "  (if (not (null? args))\n"
    "      (error \"alist->hash-table: unsupported optional arguments\"))\n"
    "  (%require-proper-list \"alist->hash-table\" alist)\n"
    "  (let ((table (make-hash-table)))\n"
    "    (for-each\n"
    "     (lambda (entry)\n"
    "       (if (not (pair? entry))\n"
    "           (error \"alist->hash-table: expected an association list\"))\n"
    "       (hash-table-set! table (car entry) (cdr entry)))\n"
    "     alist)\n"
    "    table))\n"
    "\n"
    "(define (hash-table-ref/default table key default)\n"
    "  (if (hash-table-exists? table key)\n"
    "      (%hash-table-ref-primitive table key)\n"
    "      default))\n"
    "\n"
    "(define (hash-table-hash-function table)\n"
    "  (lambda (key . maybe-bound)\n"
    "    (if (> (length maybe-bound) 1)\n"
    "        (error \"hash-table-hash-function: expected at most one bound\"))\n"
    "    (if (null? maybe-bound)\n"
    "        (%hash-table-hash table key)\n"
    "        (%hash-table-hash table key (car maybe-bound)))))\n"
    "\n"
    "(define (hash-table-update!/default table key proc default)\n"
    "  (hash-table-update! table key proc (lambda () default)))\n"
    "\n"
    "(define (hash-table-update! table key proc . maybe-get-default)\n"
    "  (if (> (length maybe-get-default) 1)\n"
    "      (error \"hash-table-update!: too many arguments\"))\n"
    "  ; The optional 4th argument is a THUNK invoked to produce the default\n"
    "  ; when key is absent (SRFI-69/R7RS-large convention, matches MIT), not\n"
    "  ; a literal default value.\n"
    "  (let ((current\n"
    "          (if (hash-table-exists? table key)\n"
    "              (hash-table-ref table key)\n"
    "              (if (null? maybe-get-default)\n"
    "                  (error \"hash-table-update!: key not found\" key)\n"
    "                  ((car maybe-get-default))))))\n"
    "    (hash-table-set! table key (proc current))))\n"
    "\n"
    "(define (hash-table-walk table proc)\n"
    "  (for-each (lambda (entry)\n"
    "              (proc (car entry) (cdr entry)))\n"
    "            (hash-table->alist table)))\n"
    "\n"
    "(define (hash-table-merge! table1 table2)\n"
    "  (hash-table-walk table2\n"
    "                   (lambda (key value)\n"
    "                     (hash-table-set! table1 key value)))\n"
    "  table1)\n"
    "\n"
    "(define (hash-table-for-each proc table)\n"
    "  (hash-table-walk table proc))\n"
    "\n"
    "(define (hash-table-fold table proc init)\n"
    "  (let loop ((entries (hash-table->alist table)) (acc init))\n"
    "    (if (null? entries)\n"
    "        acc\n"
    "        (let ((entry (car entries)))\n"
    "          (loop (cdr entries)\n"
    "                (proc (car entry) (cdr entry) acc))))))\n"
    "\n"
    "(define (hash-table-map proc table)\n"
    "  (if (not (procedure? proc))\n"
    "      (error \"hash-table-map: expected procedure\"))\n"
    "  (map (lambda (entry) (proc (car entry) (cdr entry)))\n"
    "       (hash-table->alist table)))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Vector and string library additions\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (%require-vector-range who vec start end)\n"
    "  (if (not (vector? vec))\n"
    "      (error (string-append who \": expected vector\")))\n"
    "  (%require-nonnegative-integer who start)\n"
    "  (%require-nonnegative-integer who end)\n"
    "  (let ((len (vector-length vec)))\n"
    "    (if (or (> start end) (> end len))\n"
    "        (error (string-append who \": invalid vector range\"))))\n"
    "  #t)\n"
    "\n"
    "(define (vector-copy vec . rest)\n"
    "  (if (> (length rest) 2)\n"
    "      (error \"vector-copy: too many arguments\"))\n"
    "  (let* ((start (if (pair? rest) (car rest) 0))\n"
    "         (rest2 (if (pair? rest) (cdr rest) '()))\n"
    "         (end (if (pair? rest2) (car rest2) (if (vector? vec)\n"
    "                                                 (vector-length vec)\n"
    "                                                 0))))\n"
    "    (%require-vector-range \"vector-copy\" vec start end)\n"
    "    (let* ((len (- end start))\n"
    "           (out (make-vector len)))\n"
    "    (let loop ((i 0))\n"
    "      (if (= i len)\n"
    "          out\n"
    "          (begin\n"
    "            (vector-set! out i (vector-ref vec (+ start i)))\n"
    "            (loop (+ i 1))))))))\n"
    "\n"
    "(define (vector-copy! to at from . rest)\n"
    "  (if (> (length rest) 2)\n"
    "      (error \"vector-copy!: too many arguments\"))\n"
    "  (let* ((start (if (pair? rest) (car rest) 0))\n"
    "         (rest2 (if (pair? rest) (cdr rest) '()))\n"
    "         (end (if (pair? rest2) (car rest2) (if (vector? from)\n"
    "                                                 (vector-length from)\n"
    "                                                 0))))\n"
    "    (%require-vector-range \"vector-copy!\" from start end)\n"
    "    (if (not (vector? to))\n"
    "        (error \"vector-copy!: expected destination vector\"))\n"
    "    (%require-nonnegative-integer \"vector-copy!\" at)\n"
    "    (let* ((len (- end start))\n"
    "           (to-len (vector-length to)))\n"
    "      (if (> at to-len)\n"
    "          (error \"vector-copy!: destination index out of bounds\"))\n"
    "      (if (> len (- to-len at))\n"
    "          (error \"vector-copy!: destination too short\"))\n"
    "      ; Copy through a temporary vector so overlapping source and destination\n"
    "      ; ranges have the same well-defined behavior as the documented API.\n"
    "      (let ((tmp (vector-copy from start end)))\n"
    "      (let loop ((i 0))\n"
    "        (if (= i len)\n"
    "           '()\n"
    "          (begin\n"
    "            (vector-set! to (+ at i) (vector-ref tmp i))\n"
    "            (loop (+ i 1)))))))))\n"
    "\n"
    "(define (vector-append . vecs)\n"
    "  (list->vector (apply append (map vector->list vecs))))\n"
    "\n"
    "(define (vector-map proc vec . vecs)\n"
    "  (list->vector (apply map proc (vector->list vec) (map vector->list vecs))))\n"
    "\n"
    "(define (vector-for-each proc vec . vecs)\n"
    "  (apply for-each proc (vector->list vec) (map vector->list vecs)))\n"
    "\n"
    "(define (string-map proc str . strs)\n"
    "  (list->string (apply map proc (string->list str) (map string->list strs))))\n"
    "\n"
    "(define (string-for-each proc str . strs)\n"
    "  (apply for-each proc (string->list str) (map string->list strs)))\n"
    "\n"
    "(define (string* objects)\n"
    "  (%require-proper-list \"string*\" objects)\n"
    "  (call-with-output-string\n"
    "    (lambda (port)\n"
    "      (for-each (lambda (obj) (display obj port)) objects))))\n"
    "\n"
    "(define (string-append* strings)\n"
    "  (%require-proper-list \"string-append*\" strings)\n"
    "  (for-each\n"
    "    (lambda (string)\n"
    "      (if (not (string? string))\n"
    "          (error \"string-append*: expected a list of strings\")))\n"
    "    strings)\n"
    "  (apply string-append strings))\n"
    "\n"
    "(define (string-compare string1 string2 if-eq if-lt if-gt)\n"
    "  (cond ((string=? string1 string2) (if-eq))\n"
    "        ((string<? string1 string2) (if-lt))\n"
    "        (else (if-gt))))\n"
    "\n"
    "(define (string-compare-ci string1 string2 if-eq if-lt if-gt)\n"
    "  (string-compare (string-foldcase string1)\n"
    "                  (string-foldcase string2)\n"
    "                  if-eq\n"
    "                  if-lt\n"
    "                  if-gt))\n"
    "\n"
    "(define (string-upper-case? str)\n"
    "  (let loop ((chars (string->list str)))\n"
    "    (cond ((null? chars) #t)\n"
    "          ((char-alphabetic? (car chars))\n"
    "           (and (char-upper-case? (car chars))\n"
    "                (loop (cdr chars))))\n"
    "          (else\n"
    "           (loop (cdr chars))))))\n"
    "\n"
    "(define (string-lower-case? str)\n"
    "  (let loop ((chars (string->list str)))\n"
    "    (cond ((null? chars) #t)\n"
    "          ((char-alphabetic? (car chars))\n"
    "           (and (char-lower-case? (car chars))\n"
    "                (loop (cdr chars))))\n"
    "          (else\n"
    "           (loop (cdr chars))))))\n"
    "\n"
    "(define (string-count proc str . strs)\n"
    "  (let ((count 0))\n"
    "    (apply string-for-each\n"
    "           (lambda chars\n"
    "             (if (apply proc chars)\n"
    "                 (set! count (+ count 1))))\n"
    "           str\n"
    "           strs)\n"
    "    count))\n"
    "\n"
    "(define (string-any proc str . strs)\n"
    "  (let loop ((char-lists (cons (string->list str) (map string->list strs))))\n"
    "    (if (or (null? char-lists) (any null? char-lists))\n"
    "        #f\n"
    "        (let ((value (apply proc (map car char-lists))))\n"
    "          (if value\n"
    "              value\n"
    "              (loop (map cdr char-lists)))))))\n"
    "\n"
    "(define (string-every proc str . strs)\n"
    "  (let loop ((char-lists (cons (string->list str) (map string->list strs)))\n"
    "             (last #t))\n"
    "    (if (or (null? char-lists) (any null? char-lists))\n"
    "        last\n"
    "        (let ((value (apply proc (map car char-lists))))\n"
    "          (if value\n"
    "              (loop (map cdr char-lists) value)\n"
    "              #f)))))\n"
    "\n"
    "(define (string-null? str)\n"
    "  (= (string-length str) 0))\n"
    "\n"
    "(define (string-head str end)\n"
    "  (substring str 0 end))\n"
    "\n"
    "(define (string-tail str start)\n"
    "  (substring str start))\n"
    "\n"
    "(define (string-hash str . maybe-modulus)\n"
    "  (if (> (length maybe-modulus) 1)\n"
    "      (error \"string-hash: expected at most one modulus\"))\n"
    "  (let ((has-modulus? (pair? maybe-modulus))\n"
    "        (modulus (if (pair? maybe-modulus) (car maybe-modulus) #f)))\n"
    "    ;; A supplied #f is still an argument and must not be confused with\n"
    "    ;; the omitted-modulus case.\n"
    "    (if (and has-modulus?\n"
    "             (or (not (exact-integer? modulus))\n"
    "                 (<= modulus 0)))\n"
    "        (error \"string-hash: modulus must be a positive integer\"))\n"
    "    ; MIT/GNU Scheme's SRFI-69 hash is FNV-1a over each character's\n"
    "    ; minimal little-endian byte representation, reduced to 32 bits after\n"
    "    ; every byte.  Processing code points rather than UTF-8 bytes is\n"
    "    ; important for compatibility with non-ASCII strings.\n"
    "    (let loop ((chars (string->list str)) (hash 2166136261))\n"
    "      (if (null? chars)\n"
    "          (if has-modulus? (modulo hash modulus) hash)\n"
    "          (let byte-loop ((code (char->integer (car chars)))\n"
    "                          (hash hash))\n"
    "            (let ((next (modulo\n"
    "                         (* (bitwise-xor hash (modulo code 256))\n"
    "                            16777619)\n"
    "                         4294967296)))\n"
    "              (if (< code 256)\n"
    "                  (loop (cdr chars) next)\n"
    "                  (byte-loop (quotient code 256) next))))))))\n"
    "\n"
    "(define (string-hash-ci str . maybe-modulus)\n"
    "  (apply string-hash (string-foldcase str) maybe-modulus))\n"
    "\n"
    ";; SRFI-69 names the case-insensitive variant string-ci-hash.  Keep the\n"
    ";; existing MIT-compatible spelling as an alias as well.\n"
    "(define string-ci-hash string-hash-ci)\n"
    "\n"
    "(define (string-builder . maybe-buffer-length)\n"
    "  (if (or (> (length maybe-buffer-length) 1)\n"
    "          (and (pair? maybe-buffer-length)\n"
    "               (or (not (exact-nonnegative-integer?\n"
    "                          (car maybe-buffer-length)))\n"
    "                   (= (car maybe-buffer-length) 0))))\n"
    "      (error \"string-builder: buffer length must be a positive integer\"))\n"
    "  (let ((chunks '())\n"
    "        (count 0))\n"
    "    ; Keep pieces as a list while building, but finalize through a string\n"
    "    ; port.  Applying string-append to every piece imposes the VM's argument\n"
    "    ; limit and needlessly constructs a large argument frame.\n"
    "    (let ((finish\n"
    "           (lambda ()\n"
    "             (call-with-output-string\n"
    "               (lambda (port)\n"
    "                 (for-each (lambda (piece) (display piece port))\n"
    "                           (reverse chunks)))))))\n"
    "      (lambda args\n"
    "      (if (> (length args) 1)\n"
    "          (error \"string-builder: expected at most one argument\"))\n"
    "      (cond\n"
    "        ((null? args)\n"
    "         (finish))\n"
    "        ((eq? (car args) 'immutable)\n"
    "         (finish))\n"
    "        ((eq? (car args) 'mutable)\n"
    "         (string-copy (finish)))\n"
    "        ((eq? (car args) 'nfc)\n"
    "         (string-normalize-nfc (finish)))\n"
    "        ((eq? (car args) 'empty?)\n"
    "         (= count 0))\n"
    "        ((eq? (car args) 'count)\n"
    "         count)\n"
    "        ((eq? (car args) 'reset!)\n"
    "         (set! chunks '())\n"
    "         (set! count 0))\n"
    "        ((char? (car args))\n"
    "         (let ((piece (string (car args))))\n"
    "           (set! chunks (cons piece chunks))\n"
    "           (set! count (+ count 1))))\n"
    "        ((string? (car args))\n"
    "         (set! chunks (cons (car args) chunks))\n"
    "         (set! count (+ count (string-length (car args)))))\n"
    "        (else\n"
    "         (error \"string-builder: expected character, string, or command\"\n"
    "                (car args))))))))\n"
    "\n"
    "(define (check-keyword-args args keys name)\n"
    "  (let loop ((xs args) (seen '()))\n"
    "    (if (null? xs)\n"
    "        #t\n"
    "        (if (null? (cdr xs))\n"
    "            (error name \"keyword argument missing value\")\n"
    "            (let ((key (car xs)))\n"
    "              (if (or (not (symbol? key))\n"
    "                      (not (memq key keys)))\n"
    "                  (error name \"unknown keyword\" key)\n"
    "                  (if (memq key seen)\n"
    "                      (error name \"duplicate keyword\" key)\n"
    "                      (loop (cddr xs) (cons key seen)))))))))\n"
    "\n"
    "(define (keyword-arg args key default)\n"
    "  (let loop ((xs args))\n"
    "    (cond ((null? xs) default)\n"
    "          ((null? (cdr xs)) (error \"keyword argument missing value\" key))\n"
    "          ((eq? (car xs) key) (cadr xs))\n"
    "          (else (loop (cddr xs))))))\n"
    "\n"
    "; string-join - join strings with an optional separator/prefix/suffix.\n"
    "; Each argument is picked up positionally (like the other optional-arg\n"
    "; wrappers in this file), so 1 or 2 optional args apply just that many\n"
    "; instead of silently discarding a 2-arg (sep, prefix) call.\n"
    "(define (string-join strings . args)\n"
    "  (%require-proper-list \"string-join\" strings)\n"
    "  (for-each\n"
    "    (lambda (string)\n"
    "      (if (not (string? string))\n"
    "          (error \"string-join: expected a list of strings\")))\n"
    "    strings)\n"
    "  (if (> (length args) 3)\n"
    "      (error \"string-join: expected at most separator, prefix, and suffix\"))\n"
    "  (let* ((infix (if (pair? args) (car args) \" \"))\n"
    "         (rest1 (if (pair? args) (cdr args) '()))\n"
    "         (prefix (if (pair? rest1) (car rest1) \"\"))\n"
    "         (rest2 (if (pair? rest1) (cdr rest1) '()))\n"
    "         (suffix (if (pair? rest2) (car rest2) \"\")))\n"
    "    (if (or (not (string? infix))\n"
    "            (not (string? prefix))\n"
    "            (not (string? suffix)))\n"
    "        (error \"string-join: expected string separator, prefix, and suffix\"))\n"
    "    ; Write each component once.  Repeated string-append would copy the\n"
    "    ; growing prefix on every iteration, making long joins quadratic.\n"
    "    (call-with-output-string\n"
    "     (lambda (port)\n"
    "       (write-string prefix port)\n"
    "       (let loop ((xs strings) (first? #t))\n"
    "         (if (null? xs)\n"
    "             (write-string suffix port)\n"
    "             (begin\n"
    "               (if (not first?)\n"
    "                   (write-string infix port))\n"
    "               (write-string (car xs) port)\n"
    "               (loop (cdr xs) #f))))))))\n"
    "\n"
    "(define (string-joiner . args)\n"
    "  (check-keyword-args args '(infix prefix suffix) \"string-joiner\")\n"
    "  (let ((infix (keyword-arg args 'infix \"\"))\n"
    "        (prefix (keyword-arg args 'prefix \"\"))\n"
    "        (suffix (keyword-arg args 'suffix \"\")))\n"
    "    (if (or (not (string? infix))\n"
    "            (not (string? prefix))\n"
    "            (not (string? suffix)))\n"
    "        (error \"string-joiner: infix, prefix, and suffix must be strings\"))\n"
    "    (lambda strings\n"
    "      (string-join strings infix prefix suffix))))\n"
    "\n"
    "(define (string-joiner* . args)\n"
    "  (let ((joiner (apply string-joiner args)))\n"
    "    (lambda (strings)\n"
    "      (apply joiner strings))))\n"
    "\n"
    "(define (delimiter-procedure delimiter)\n"
    "  (cond ((procedure? delimiter) delimiter)\n"
    "        ((char? delimiter) (lambda (ch) (char=? ch delimiter)))\n"
    "        ((char-set? delimiter)\n"
    "         (lambda (ch) (char-in-set? ch delimiter)))\n"
    "        (else (error \"string-splitter: unsupported delimiter\" delimiter))))\n"
    "\n"
    "(define (string-splitter . args)\n"
    "  (check-keyword-args args '(delimiter allow-runs? copier copy?) \"string-splitter\")\n"
    "  (let ((delimiter (delimiter-procedure\n"
    "                     (keyword-arg args 'delimiter char-whitespace?)))\n"
    "        (allow-runs? (keyword-arg args 'allow-runs? #t))\n"
    "        (copy? (keyword-arg args 'copy? #f))\n"
    "        (copier (keyword-arg args 'copier string-slice)))\n"
    "    (if (not (boolean? allow-runs?))\n"
    "        (error \"string-splitter: allow-runs? must be boolean\"))\n"
    "    (if (not (boolean? copy?))\n"
    "        (error \"string-splitter: copy? must be boolean\"))\n"
    "    (if (not (procedure? copier))\n"
    "        (error \"string-splitter: copier must be a procedure\"))\n"
    "    ; MIT validates an explicitly supplied copier even when copy? would\n"
    "    ; otherwise replace it with substring.\n"
    "    (if copy? (set! copier substring))\n"
    "    (lambda (str)\n"
    "      (let ((len (string-length str)))\n"
    "        (let loop ((i 0) (start 0) (parts '()))\n"
    "          (cond\n"
    "            ((>= i len)\n"
    "             (reverse (if (and allow-runs? (= start i))\n"
    "                          parts\n"
    "                          (cons (copier str start i) parts))))\n"
    "            ((delimiter (string-ref str i))\n"
    "             (let skip ((j (+ i 1)))\n"
    "               (if (and allow-runs?\n"
    "                        (< j len)\n"
    "                        (delimiter (string-ref str j)))\n"
    "                   (skip (+ j 1))\n"
    "                   (loop j j\n"
    "                         (if (and allow-runs? (= start i))\n"
    "                             parts\n"
    "                             (cons (copier str start i) parts))))))\n"
    "            (else\n"
    "             (loop (+ i 1) start parts))))))))\n"
    "\n"
    ";; Repeats via one string-append per remaining copy, each on a string that\n"
    ";; has grown by one more `piece`, is O(count^2 * (string-length piece))\n"
    ";; overall - noticeable once count reaches the tens of thousands (e.g.\n"
    ";; string-pad-left/right on a large target width). Halving instead gives\n"
    ";; O(log count) appends, each on progressively doubling strings, for\n"
    ";; O(count * (string-length piece)) total work.\n"
    "(define (repeat-string piece count)\n"
    "  (cond\n"
    "    ((<= count 0) \"\")\n"
    "    ((= count 1) piece)\n"
    "    (else\n"
    "     (let ((half (repeat-string piece (quotient count 2))))\n"
    "       (if (even? count)\n"
    "           (string-append half half)\n"
    "           (string-append half half piece))))))\n"
    "\n"
    ";; A grapheme here follows the common extended-cluster cases needed by the\n"
    ";; padding utilities: combining/variation marks, emoji modifiers, ZWJ joins,\n"
    ";; and paired regional indicators.  The internal predicate is backed by\n"
    ";; Unicode combining classes.  Ordinary string APIs remain code-point based.\n"
    "(define (%code-point-between? code low high)\n"
    "  (and (<= low code) (<= code high)))\n"
    "\n"
    "(define (%string-grapheme-extend? char)\n"
    "  (let ((code (char->integer char)))\n"
    "    (or (%char-combining? char)\n"
    "        (%code-point-between? code #xFE00 #xFE0F)\n"
    "        (%code-point-between? code #xE0100 #xE01EF)\n"
    "        (%code-point-between? code #x1F3FB #x1F3FF))))\n"
    "\n"
    "(define (%string-grapheme-regional-indicator? char)\n"
    "  (%code-point-between? (char->integer char) #x1F1E6 #x1F1FF))\n"
    "\n"
    "(define (%string-grapheme-boundaries str)\n"
    "  (let ((length (string-length str)))\n"
    "    (let loop ((i 0)\n"
    "               (boundaries (if (> length 0) '(0) '()))\n"
    "               (previous #f)\n"
    "               (regional-run 0))\n"
    "      (if (= i length)\n"
    "          (reverse (cons length boundaries))\n"
    "          (let* ((current (string-ref str i))\n"
    "                 (regional? (%string-grapheme-regional-indicator? current))\n"
    "                 (previous-regional?\n"
    "                  (and previous\n"
    "                       (%string-grapheme-regional-indicator? previous)))\n"
    "                 (joined? (and previous (char=? previous #\\x200d)))\n"
    "                 (current-zwj? (char=? current #\\x200d))\n"
    "                 (paired-regional?\n"
    "                  (and regional? previous-regional? (odd? regional-run)))\n"
    "                 (boundary?\n"
    "                  (and (> i 0)\n"
    "                       (not (or (%string-grapheme-extend? current)\n"
    "                                joined?\n"
    "                                current-zwj?\n"
    "                                paired-regional?))))\n"
    "                 (next-boundaries (if boundary?\n"
    "                                     (cons i boundaries)\n"
    "                                     boundaries))\n"
    "                 (next-regional-run (if regional? (+ regional-run 1) 0)))\n"
    "            (loop (+ i 1) next-boundaries current next-regional-run))))))\n"
    "\n"
    "(define (%string-grapheme-count str)\n"
    "  (- (length (%string-grapheme-boundaries str)) 1))\n"
    "\n"
    "(define (string-padder . args)\n"
    "  (check-keyword-args args '(where fill-with clip?) \"string-padder\")\n"
    "  (let ((where (keyword-arg args 'where 'leading))\n"
    "        (fill-with (keyword-arg args 'fill-with \" \"))\n"
    "        (clip? (keyword-arg args 'clip? #t)))\n"
    "    (if (not (or (eq? where 'leading) (eq? where 'trailing)))\n"
    "        (error \"string-padder: where must be leading or trailing\"))\n"
    "    (if (or (not (string? fill-with))\n"
    "            (not (= (%string-grapheme-count fill-with) 1)))\n"
    "        (error \"string-padder: fill-with must contain exactly one grapheme\"))\n"
    "    (if (not (boolean? clip?))\n"
    "        (error \"string-padder: clip? must be boolean\"))\n"
    "    (lambda (str len)\n"
    "      (%require-nonnegative-integer \"string-padder\" len)\n"
    "      (let* ((boundaries (%string-grapheme-boundaries str))\n"
    "             (n (- (length boundaries) 1)))\n"
    "        (cond\n"
    "          ((< n len)\n"
    "           (let ((padding (repeat-string fill-with (- len n))))\n"
    "             (if (eq? where 'trailing)\n"
    "                 (string-append str padding)\n"
    "                 (string-append padding str))))\n"
    "          ((and clip? (> n len))\n"
    "           (let ((start (if (eq? where 'trailing)\n"
    "                            0\n"
    "                            (list-ref boundaries (- n len))))\n"
    "                 (end (if (eq? where 'trailing)\n"
    "                          (list-ref boundaries len)\n"
    "                          (string-length str))))\n"
    "             (substring str start end)))\n"
    "          (else str))))))\n"
    "\n"
    "(define (string-pad-left str k . maybe-char)\n"
    "  (if (> (length maybe-char) 1)\n"
    "      (error \"string-pad-left: too many arguments\"))\n"
    "  ((string-padder 'where 'leading\n"
    "                  'fill-with (string (if (null? maybe-char)\n"
    "                                         #\\space\n"
    "                                         (car maybe-char))))\n"
    "   str\n"
    "   k))\n"
    "\n"
    "(define (string-pad-right str k . maybe-char)\n"
    "  (if (> (length maybe-char) 1)\n"
    "      (error \"string-pad-right: too many arguments\"))\n"
    "  ((string-padder 'where 'trailing\n"
    "                  'fill-with (string (if (null? maybe-char)\n"
    "                                         #\\space\n"
    "                                         (car maybe-char))))\n"
    "   str\n"
    "   k))\n"
    "\n"
    "(define (trim-procedure to-trim)\n"
    "  (cond ((procedure? to-trim) to-trim)\n"
    "        ((char? to-trim) (lambda (ch) (char=? ch to-trim)))\n"
    "        ((char-set? to-trim) (lambda (ch) (char-in-set? ch to-trim)))\n"
    "        (else (error \"string-trimmer: unsupported trim predicate\" to-trim))))\n"
    "\n"
    "(define (string-trimmer . args)\n"
    "  (check-keyword-args args '(where to-trim copier copy?) \"string-trimmer\")\n"
    "  (let ((where (keyword-arg args 'where 'both))\n"
    "        (to-trim (trim-procedure (keyword-arg args 'to-trim char-whitespace?)))\n"
    "        (copy? (keyword-arg args 'copy? #f))\n"
    "        (copier (keyword-arg args 'copier string-slice)))\n"
    "    (if (not (or (eq? where 'leading)\n"
    "                 (eq? where 'trailing)\n"
    "                 (eq? where 'both)))\n"
    "        (error \"string-trimmer: where must be leading, trailing, or both\"))\n"
    "    (if (not (boolean? copy?))\n"
    "        (error \"string-trimmer: copy? must be boolean\"))\n"
    "    (if (not (procedure? copier))\n"
    "        (error \"string-trimmer: copier must be a procedure\"))\n"
    "    (if copy? (set! copier substring))\n"
    "    (lambda (str)\n"
    "      (let* ((len (string-length str))\n"
    "             (start (if (or (eq? where 'leading) (eq? where 'both))\n"
    "                        (let loop ((i 0))\n"
    "                          (if (and (< i len) (to-trim (string-ref str i)))\n"
    "                              (loop (+ i 1))\n"
    "                              i))\n"
    "                        0))\n"
    "             (end (if (or (eq? where 'trailing) (eq? where 'both))\n"
    "                      (let loop ((i (- len 1)))\n"
    "                        (if (and (>= i start) (to-trim (string-ref str i)))\n"
    "                            (loop (- i 1))\n"
    "                            (+ i 1)))\n"
    "                      len)))\n"
    "        (copier str start end)))))\n"
    "\n"
    "(define (string-replace str char1 char2)\n"
    "  (if (not (char? char1))\n"
    "      (error \"string-replace: expected first character\"))\n"
    "  (if (not (char? char2))\n"
    "      (error \"string-replace: expected replacement character\"))\n"
    "  (list->string\n"
    "    (map (lambda (ch) (if (char=? ch char1) char2 ch))\n"
    "         (string->list str))))\n"
    "\n"
    "(define (%require-string-range who str start end)\n"
    "  (if (not (string? str))\n"
    "      (error (string-append who \": expected string\")))\n"
    "  (%require-nonnegative-integer who start)\n"
    "  (%require-nonnegative-integer who end)\n"
    "  (let ((len (string-length str)))\n"
    "    (if (or (> start end) (> end len))\n"
    "        (error (string-append who \": invalid string range\"))))\n"
    "  #t)\n"
    "\n"
    "(define (string-copy! to at from . rest)\n"
    "  (if (> (length rest) 2)\n"
    "      (error \"string-copy!: too many arguments\"))\n"
    "  (let* ((start (if (pair? rest) (car rest) 0))\n"
    "         (rest2 (if (pair? rest) (cdr rest) '()))\n"
    "         (end (if (pair? rest2) (car rest2)\n"
    "                  (if (string? from) (string-length from) 0))))\n"
    "    (%require-string-range \"string-copy!\" from start end)\n"
    "    (if (not (string? to))\n"
    "        (error \"string-copy!: expected destination string\"))\n"
    "    ; Force the destination mutability check even when count is zero.  The\n"
    "    ; empty fill is a no-op for mutable strings and avoids silently accepting\n"
    "    ; an immutable destination when the copy loop has no iterations.\n"
    "    (string-fill! to #\\space 0 0)\n"
    "    (%require-nonnegative-integer \"string-copy!\" at)\n"
    "    (let ((count (- end start)))\n"
    "      (if (> at (string-length to))\n"
    "          (error \"string-copy!: destination index out of bounds\"))\n"
    "      (if (> count (- (string-length to) at))\n"
    "          (error \"string-copy!: destination too short\"))\n"
    "      ; Read the source before writing so overlapping source/destination\n"
    "      ; ranges behave as if the source were copied to a temporary string.\n"
    "      (let ((temp (string-copy from start end)))\n"
    "    (let loop ((i 0) (j at))\n"
    "      (if (= i (string-length temp))\n"
    "          j\n"
    "          (begin\n"
    "            (string-set! to j (string-ref temp i))\n"
    "            (loop (+ i 1) (+ j 1)))))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Additional R7RS compatibility procedures\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (boolean=? first second . rest)\n"
    "  (and (boolean? first)\n"
    "       (boolean? second)\n"
    "       (eq? first second)\n"
    "       (let loop ((xs rest))\n"
    "         (or (null? xs)\n"
    "             (and (boolean? (car xs))\n"
    "                  (eq? first (car xs))\n"
    "                  (loop (cdr xs)))))))\n"
    "\n"
    "(define (call-with-port port proc)\n"
    "  (let ((returned? #f))\n"
    "    (dynamic-wind\n"
    "      (lambda () #f)\n"
    "      (lambda ()\n"
    "        (call-with-values\n"
    "          (lambda () (proc port))\n"
    "          (lambda results\n"
    "            (set! returned? #t)\n"
    "            (apply values results))))\n"
    "      (lambda ()\n"
    "        (if returned?\n"
    "            (close-port port))))))\n"
    "\n"
    "(define (close-port port)\n"
    "  (cond\n"
    "    ((input-port? port) (close-input-port port))\n"
    "    ((output-port? port) (close-output-port port))\n"
    "    (else (error \"close-port: not a port\"))))\n"
    "\n"
    "(define exact inexact->exact)\n"
    "(define inexact exact->inexact)\n"
    "\n"
    "(define (exact-integer? x)\n"
    "  (and (integer? x) (exact? x)))\n"
    "\n"
    "(define (exact-integer-sqrt n)\n"
    "  (if (not (exact-nonnegative-integer? n))\n"
    "      (error \"exact-integer-sqrt: expected exact nonnegative integer\" n)\n"
    "      (let loop ((lo 0) (hi (+ n 1)))\n"
    "        (if (<= (- hi lo) 1)\n"
    "            (values lo (- n (* lo lo)))\n"
    "            (let* ((mid (quotient (+ lo hi) 2))\n"
    "                   (sq (* mid mid)))\n"
    "              (if (<= sq n)\n"
    "                  (loop mid hi)\n"
    "                  (loop lo mid)))))))\n"
    "\n"
    "(define (exact-nonnegative-integer? x)\n"
    "  (and (exact-integer? x) (>= x 0)))\n"
    "\n"
    "(define (exact-rational? x)\n"
    "  (and (rational? x) (exact? x)))\n"
    "\n"
    "(define (1+ z) (+ z 1))\n"
    "(define (-1+ z) (- z 1))\n"
    "\n"
    "(define (copysign x y)\n"
    "  (let ((mag (abs x)))\n"
    "    (if (or (< y 0)\n"
    "            (and (= y 0) (< (/ 1.0 y) 0)))\n"
    "        (- mag)\n"
    "        mag)))\n"
    "\n"
    "(define (integer-select divproc n d selector)\n"
    "  (call-with-values\n"
    "    (lambda () (divproc n d))\n"
    "    selector))\n"
    "\n"
    "(define (euclidean/ n d)\n"
    "  (call-with-values\n"
    "    (lambda () (truncate/ n d))\n"
    "    (lambda (q r)\n"
    "      (cond\n"
    "        ((< r 0)\n"
    "         (if (> d 0)\n"
    "             (values (- q 1) (+ r d))\n"
    "             (values (+ q 1) (- r d))))\n"
    "        (else (values q r))))))\n"
    "\n"
    "(define (ceiling/ n d)\n"
    "  (call-with-values\n"
    "    (lambda () (truncate/ n d))\n"
    "    (lambda (q r)\n"
    "      (if (and (not (= r 0))\n"
    "               (or (and (> n 0) (> d 0))\n"
    "                   (and (< n 0) (< d 0))))\n"
    "          (values (+ q 1) (- r d))\n"
    "          (values q r)))))\n"
    "\n"
    "(define (round/ n d)\n"
    "  (call-with-values\n"
    "    (lambda () (truncate/ n d))\n"
    "    (lambda (q r)\n"
    "      (let* ((abs-r (abs r))\n"
    "             (abs-d (abs d))\n"
    "             (twice-r (* 2 abs-r))\n"
    "             (same-sign? (or (and (> n 0) (> d 0))\n"
    "                             (and (< n 0) (< d 0))))\n"
    "             (adjust? (or (> twice-r abs-d)\n"
    "                          (and (= twice-r abs-d) (odd? q)))))\n"
    "        (if adjust?\n"
    "            (if same-sign?\n"
    "                (values (+ q 1) (- r d))\n"
    "                (values (- q 1) (+ r d)))\n"
    "            (values q r))))))\n"
    "\n"
    "(define (euclidean-quotient n d)\n"
    "  (integer-select euclidean/ n d (lambda (q r) q)))\n"
    "\n"
    "(define (euclidean-remainder n d)\n"
    "  (integer-select euclidean/ n d (lambda (q r) r)))\n"
    "\n"
    "(define (floor-quotient n d)\n"
    "  (call-with-values\n"
    "    (lambda () (floor/ n d))\n"
    "    (lambda (q r) q)))\n"
    "\n"
    "(define (floor-remainder n d)\n"
    "  (call-with-values\n"
    "    (lambda () (floor/ n d))\n"
    "    (lambda (q r) r)))\n"
    "\n"
    "(define (ceiling-quotient n d)\n"
    "  (integer-select ceiling/ n d (lambda (q r) q)))\n"
    "\n"
    "(define (ceiling-remainder n d)\n"
    "  (integer-select ceiling/ n d (lambda (q r) r)))\n"
    "\n"
    "(define (truncate-quotient n d)\n"
    "  (call-with-values\n"
    "    (lambda () (truncate/ n d))\n"
    "    (lambda (q r) q)))\n"
    "\n"
    "(define (truncate-remainder n d)\n"
    "  (call-with-values\n"
    "    (lambda () (truncate/ n d))\n"
    "    (lambda (q r) r)))\n"
    "\n"
    "(define (round-quotient n d)\n"
    "  (integer-select round/ n d (lambda (q r) q)))\n"
    "\n"
    "(define (round-remainder n d)\n"
    "  (integer-select round/ n d (lambda (q r) r)))\n"
    "\n"
    "(define integer-floor floor-quotient)\n"
    "(define integer-ceiling ceiling-quotient)\n"
    "(define integer-truncate truncate-quotient)\n"
    "(define integer-round round-quotient)\n"
    "\n"
    "(define (integer-divide n d)\n"
    "  (call-with-values\n"
    "    (lambda () (truncate/ n d))\n"
    "    (lambda (q r) (vector q r))))\n"
    "\n"
    "(define (integer-divide-quotient qr)\n"
    "  (vector-ref qr 0))\n"
    "\n"
    "(define (integer-divide-remainder qr)\n"
    "  (vector-ref qr 1))\n"
    "\n"
    "(define (modexp b e m)\n"
    "  (if (not (exact-integer? b))\n"
    "      (error \"modexp: base must be an exact integer\"))\n"
    "  (if (not (exact-nonnegative-integer? e))\n"
    "      (error \"modexp: exponent must be a nonnegative exact integer\"))\n"
    "  (if (not (and (exact-integer? m) (> m 0)))\n"
    "      (error \"modexp: modulus must be a positive exact integer\"))\n"
    "  ; MIT returns 1 for exponent zero even with modulus one.  Reduce only\n"
    "  ; after an exponent bit is consumed so that identity is preserved.\n"
    "  (let loop ((base (modulo b m))\n"
    "             (exp e)\n"
    "             (result 1))\n"
    "    (cond\n"
    "      ((= exp 0) result)\n"
    "      ((odd? exp)\n"
    "       (loop (modulo (* base base) m)\n"
    "             (quotient exp 2)\n"
    "             (modulo (* result base) m)))\n"
    "      (else\n"
    "       (loop (modulo (* base base) m)\n"
    "             (quotient exp 2)\n"
    "             result)))))\n"
    "\n"
    "(define (floor->exact x) (exact (floor x)))\n"
    "(define (ceiling->exact x) (exact (ceiling x)))\n"
    "(define (truncate->exact x) (exact (truncate x)))\n"
    "(define (round->exact x) (exact (round x)))\n"
    "\n"
    "(define (rationalize->exact x y)\n"
    "  (exact (rationalize x y)))\n"
    "\n"
    "(define (simplest-rational x y)\n"
    "  (rationalize (/ (+ x y) 2) (/ (abs (- y x)) 2)))\n"
    "\n"
    "(define (simplest-exact-rational x y)\n"
    "  (exact (simplest-rational x y)))\n"
    "\n"
    "(define logp1 log1p)\n"
    "(define (exp2 z) (expt 2 z))\n"
    "(define (exp10 z) (expt 10 z))\n"
    "(define (exp2m1 z) (expm1 (* z (log 2))))\n"
    "(define (exp10m1 z) (expm1 (* z (log 10))))\n"
    "(define (log2 z) (/ (log z) (log 2)))\n"
    "(define (log10 z) (/ (log z) (log 10)))\n"
    "(define (log2p1 z) (/ (log1p z) (log 2)))\n"
    "(define (log10p1 z) (/ (log1p z) (log 10)))\n"
    "(define (log1mexp x)\n"
    "  (if (<= x (- (log 2)))\n"
    "      (log1p (- (exp x)))\n"
    "      (log (- (expm1 x)))))\n"
    "\n"
    "(define (versin z) (- 1 (cos z)))\n"
    "(define (exsec z) (/ (versin z) (cos z)))\n"
    "(define (aversin z) (acos (- 1 z)))\n"
    "(define (aexsec z) (acos (/ 1 (+ 1 z))))\n"
    "\n"
    "(define (logistic x)\n"
    "  (if (< x 0)\n"
    "      (let ((e (exp x))) (/ e (+ 1 e)))\n"
    "      (/ 1 (+ 1 (exp (- x))))))\n"
    "\n"
    "(define (logit p)\n"
    "  (log (/ p (- 1 p))))\n"
    "\n"
    "(define (logistic-1/2 x)\n"
    "  (- (logistic x) 1/2))\n"
    "\n"
    "(define (logit1/2+ p)\n"
    "  (logit (+ 1/2 p)))\n"
    "\n"
    "(define (log-logistic x)\n"
    "  (- (log1pexp (- x))))\n"
    "\n"
    "(define (logit-exp x)\n"
    "  (- x (log1mexp x)))\n"
    "\n"
    "(define (logsumexp xs)\n"
    "  (%require-proper-list \"logsumexp\" xs)\n"
    "  (if (null? xs)\n"
    "      (log 0)\n"
    "      (let ((m (apply max xs)))\n"
    "        (if (infinite? m)\n"
    "            m\n"
    "            (+ m (log (apply + (map (lambda (x) (exp (- x m))) xs))))))))\n"
    "\n"
    "(define pi (acos -1))\n"
    "(define (sin-pi* x) (sin (* pi x)))\n"
    "(define (cos-pi* x) (cos (* pi x)))\n"
    "(define (tan-pi* x) (tan (* pi x)))\n"
    "(define (versin-pi* x) (versin (* pi x)))\n"
    "(define (exsec-pi* x) (exsec (* pi x)))\n"
    "(define (asin/pi x) (/ (asin x) pi))\n"
    "(define (acos/pi x) (/ (acos x) pi))\n"
    "(define (atan/pi x) (/ (atan x) pi))\n"
    "(define (atan2/pi y x) (/ (atan y x) pi))\n"
    "(define (aversin/pi x) (/ (aversin x) pi))\n"
    "(define (aexsec/pi x) (/ (aexsec x) pi))\n"
    "\n"
    "(define (rsqrt z) (/ 1 (sqrt z)))\n"
    "(define (compound z1 z2) (expt (+ 1 z1) z2))\n"
    "(define (compoundm1 z1 z2) (expm1 (* z2 (log1p z1))))\n"
    "(define (conjugate z)\n"
    "  (make-rectangular (real-part z) (- (imag-part z))))\n"
    "\n"
    "(define (digit-value ch)\n"
    "  (let ((n (char->integer ch)))\n"
    "    (cond\n"
    "      ((and (>= n (char->integer #\\0)) (<= n (char->integer #\\9)))\n"
    "       (- n (char->integer #\\0)))\n"
    "      ((and (>= n 1632) (<= n 1641)) (- n 1632))\n"
    "      ((and (>= n 1776) (<= n 1785)) (- n 1776))\n"
    "      ((and (>= n 2406) (<= n 2415)) (- n 2406))\n"
    "      ((and (>= n 2534) (<= n 2543)) (- n 2534))\n"
    "      ((and (>= n 2662) (<= n 2671)) (- n 2662))\n"
    "      ((and (>= n 2790) (<= n 2799)) (- n 2790))\n"
    "      ((and (>= n 2918) (<= n 2927)) (- n 2918))\n"
    "      ((and (>= n 3046) (<= n 3055)) (- n 3046))\n"
    "      ((and (>= n 3174) (<= n 3183)) (- n 3174))\n"
    "      ((and (>= n 3302) (<= n 3311)) (- n 3302))\n"
    "      ((and (>= n 3430) (<= n 3439)) (- n 3430))\n"
    "      ((and (>= n 3664) (<= n 3673)) (- n 3664))\n"
    "      ((and (>= n 3792) (<= n 3801)) (- n 3792))\n"
    "      ((and (>= n 3872) (<= n 3881)) (- n 3872))\n"
    "      ((and (>= n 4160) (<= n 4169)) (- n 4160))\n"
    "      ((and (>= n 6112) (<= n 6121)) (- n 6112))\n"
    "      ((and (>= n 6160) (<= n 6169)) (- n 6160))\n"
    "      ((and (>= n 6470) (<= n 6479)) (- n 6470))\n"
    "      ((and (>= n 6608) (<= n 6617)) (- n 6608))\n"
    "      ((and (>= n 6672) (<= n 6681)) (- n 6672))\n"
    "      ((and (>= n 6784) (<= n 6793)) (- n 6784))\n"
    "      ((and (>= n 6800) (<= n 6809)) (- n 6800))\n"
    "      ((and (>= n 6992) (<= n 7001)) (- n 6992))\n"
    "      ((and (>= n 7088) (<= n 7097)) (- n 7088))\n"
    "      ((and (>= n 7232) (<= n 7241)) (- n 7232))\n"
    "      ((and (>= n 7248) (<= n 7257)) (- n 7248))\n"
    "      ((and (>= n 42528) (<= n 42537)) (- n 42528))\n"
    "      ((and (>= n 43216) (<= n 43225)) (- n 43216))\n"
    "      ((and (>= n 43264) (<= n 43273)) (- n 43264))\n"
    "      ((and (>= n 43472) (<= n 43481)) (- n 43472))\n"
    "      ((and (>= n 43504) (<= n 43513)) (- n 43504))\n"
    "      ((and (>= n 43600) (<= n 43609)) (- n 43600))\n"
    "      ((and (>= n 44016) (<= n 44025)) (- n 44016))\n"
    "      ((and (>= n 65296) (<= n 65305)) (- n 65296))\n"
    "      ;; Keep newer Unicode decimal ranges in sync with char-numeric?.\n"
    "      ((and (>= n #x07C0) (<= n #x07C9)) (- n #x07C0))\n"
    "      ((and (>= n #x1946) (<= n #x194F)) (- n #x1946))\n"
    "      ((and (>= n #x19D0) (<= n #x19D9)) (- n #x19D0))\n"
    "      ((and (>= n #x1A80) (<= n #x1A89)) (- n #x1A80))\n"
    "      ((and (>= n #x1A90) (<= n #x1A99)) (- n #x1A90))\n"
    "      ((and (>= n #x1BB0) (<= n #x1BB9)) (- n #x1BB0))\n"
    "      ((and (>= n #x1C40) (<= n #x1C49)) (- n #x1C40))\n"
    "      ((and (>= n #x1C50) (<= n #x1C59)) (- n #x1C50))\n"
    "      ((and (>= n #x1D7CE) (<= n #x1D7FF)) (- n #x1D7CE))\n"
    "      ((and (>= n #x1E140) (<= n #x1E149)) (- n #x1E140))\n"
    "      ((and (>= n #x1E2F0) (<= n #x1E2F9)) (- n #x1E2F0))\n"
    "      ((and (>= n #x1E4F0) (<= n #x1E4F9)) (- n #x1E4F0))\n"
    "      ((and (>= n #x1E950) (<= n #x1E959)) (- n #x1E950))\n"
    "      ((and (>= n #x1FBF0) (<= n #x1FBF9)) (- n #x1FBF0))\n"
    "      (else #f))))\n"
    "\n"
    "(define (char-alphanumeric? ch)\n"
    "  (if (not (char? ch))\n"
    "      (error \"char-alphanumeric?: expected character\"))\n"
    "  (or (char-alphabetic? ch) (char-numeric? ch)))\n"
    "\n"
    "(define (char->digit ch . maybe-radix)\n"
    "  (if (not (char? ch))\n"
    "      (error \"char->digit: expected character\"))\n"
    "  (if (> (length maybe-radix) 1)\n"
    "      (error \"char->digit: too many arguments\"))\n"
    "  (let ((radix (if (null? maybe-radix) 10 (car maybe-radix))))\n"
    "    (if (or (not (integer? radix)) (not (exact? radix))\n"
    "            (< radix 2) (> radix 36))\n"
    "        (error \"char->digit: radix must be an exact integer in [2,36]\"))\n"
    "    (let ((unicode-digit (digit-value ch))\n"
    "          (code (char->integer ch)))\n"
    "      (if (not (eq? unicode-digit #f))\n"
    "          (if (< unicode-digit radix) unicode-digit #f)\n"
    "          (cond\n"
    "            ((and (>= code (char->integer #\\A))\n"
    "                  (< code (+ (char->integer #\\A) 26)))\n"
    "             (let ((digit (+ 10 (- code (char->integer #\\A)))))\n"
    "               (if (< digit radix) digit #f)))\n"
    "            ((and (>= code (char->integer #\\a))\n"
    "                  (< code (+ (char->integer #\\a) 26)))\n"
    "             (let ((digit (+ 10 (- code (char->integer #\\a)))))\n"
    "               (if (< digit radix) digit #f)))\n"
    "            (else #f))))))\n"
    "\n"
    "(define (digit->char digit . maybe-radix)\n"
    "  (if (> (length maybe-radix) 1)\n"
    "      (error \"digit->char: too many arguments\"))\n"
    "  (let ((radix (if (null? maybe-radix) 10 (car maybe-radix))))\n"
    "    (if (or (not (integer? radix)) (not (exact? radix))\n"
    "            (< radix 2) (> radix 36))\n"
    "        (error \"digit->char: radix must be an exact integer in [2,36]\"))\n"
    "    (if (or (not (integer? digit)) (not (exact? digit))\n"
    "            (< digit 0) (>= digit radix))\n"
    "        (error \"digit->char: digit out of range\"))\n"
    "    (integer->char\n"
    "     (if (< digit 10)\n"
    "         (+ (char->integer #\\0) digit)\n"
    "         (+ (char->integer #\\A) (- digit 10))))))\n"
    "\n"
    "(define (char->name ch)\n"
    "  (if (not (char? ch))\n"
    "      (error \"char->name: expected character\"))\n"
    "  (let ((code (char->integer ch)))\n"
    "    (cond ((= code 7) \"alarm\")\n"
    "          ((= code 8) \"backspace\")\n"
    "          ((= code 127) \"delete\")\n"
    "          ((= code 27) \"escape\")\n"
    "          ((= code 10) \"newline\")\n"
    "          ((= code 0) \"null\")\n"
    "          ((= code 13) \"return\")\n"
    "          ((= code 32) \"space\")\n"
    "          ((= code 9) \"tab\")\n"
    "          ((and (> code 32) (< code 127)) (string ch))\n"
    "          (else (string-append \"x\" (number->string code 16))))))\n"
    "\n"
    "(define (name->char name)\n"
    "  (if (not (string? name))\n"
    "      (error \"name->char: expected string\"))\n"
    "  (if (= (string-length name) 1)\n"
    "      (string-ref name 0)\n"
    "      (let ((special\n"
    "             (cond ((string-ci=? name \"alarm\") 7)\n"
    "                   ((string-ci=? name \"backspace\") 8)\n"
    "                   ((string-ci=? name \"delete\") 127)\n"
    "                   ((string-ci=? name \"escape\") 27)\n"
    "                   ((string-ci=? name \"newline\") 10)\n"
    "                   ((string-ci=? name \"null\") 0)\n"
    "                   ((string-ci=? name \"return\") 13)\n"
    "                   ((string-ci=? name \"space\") 32)\n"
    "                   ((string-ci=? name \"tab\") 9)\n"
    "                   (else #f))))\n"
    "        ;; Code point zero is a valid result for \"null\" but is false in\n"
    "        ;; Scheme, so distinguish the absent-name sentinel explicitly.\n"
    "        (if (not (eq? special #f))\n"
    "            (integer->char special)\n"
    "            (if (and (> (string-length name) 1)\n"
    "                     (or (char=? (string-ref name 0) #\\x)\n"
    "                         (char=? (string-ref name 0) #\\X)))\n"
    "                (let ((code (string->number\n"
    "                             (substring name 1 (string-length name)) 16)))\n"
    "                  (if (and code (integer? code) (exact? code))\n"
    "                      (integer->char code)\n"
    "                      (error \"name->char: invalid character name\")))\n"
    "                (error \"name->char: invalid character name\"))))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; Pathname/File Utilities\n"
    ";;; ============================================================================\n"
    "\n"
    "(define (path-separator) \"/\")\n"
    "\n"
    "(define (path-absolute? path)\n"
    "  (and (> (string-length path) 0)\n"
    "       (char=? (string-ref path 0) #\\/)))\n"
    "\n"
    "(define (path-strip-trailing-separators path)\n"
    "  (let loop ((end (string-length path)))\n"
    "    (if (and (> end 1) (char=? (string-ref path (- end 1)) #\\/))\n"
    "        (loop (- end 1))\n"
    "        (substring path 0 end))))\n"
    "\n"
    "(define (path-join . parts)\n"
    "  (define (empty-part? s) (= (string-length s) 0))\n"
    "  (define (trim-left s)\n"
    "    (let loop ((i 0))\n"
    "      (if (and (< i (string-length s)) (char=? (string-ref s i) #\\/))\n"
    "          (loop (+ i 1))\n"
    "          (substring s i (string-length s)))))\n"
    "  (define (trim-right s)\n"
    "    (path-strip-trailing-separators s))\n"
    "  (let loop ((parts parts) (out \"\"))\n"
    "    (cond ((null? parts) (if (string=? out \"\") \".\" out))\n"
    "          ((empty-part? (car parts)) (loop (cdr parts) out))\n"
    "          ((or (string=? out \"\") (path-absolute? (car parts)))\n"
    "           (loop (cdr parts) (trim-right (car parts))))\n"
    "          (else\n"
    "           (let ((left (trim-right out))\n"
    "                 (right (trim-left (car parts))))\n"
    "             (loop (cdr parts)\n"
    "                   (if (string=? left \"/\")\n"
    "                       (string-append left right)\n"
    "                       (string-append left \"/\" right))))))))\n"
    "\n"
    "(define (path-basename path)\n"
    "  (let* ((p (path-strip-trailing-separators path))\n"
    "         (len (string-length p)))\n"
    "    (let loop ((i (- len 1)))\n"
    "      (cond ((< i 0) p)\n"
    "            ((char=? (string-ref p i) #\\/) (substring p (+ i 1) len))\n"
    "            (else (loop (- i 1)))))))\n"
    "\n"
    "(define (path-directory path)\n"
    "  (let* ((p (path-strip-trailing-separators path))\n"
    "         (len (string-length p)))\n"
    "    (let loop ((i (- len 1)))\n"
    "      (cond ((< i 0) \".\")\n"
    "            ((char=? (string-ref p i) #\\/)\n"
    "             (if (= i 0) \"/\" (substring p 0 i)))\n"
    "            (else (loop (- i 1)))))))\n"
    "\n"
    "(define (path-extension path)\n"
    "  (let ((base (path-basename path)))\n"
    "    (let loop ((i (- (string-length base) 1)))\n"
    "      (cond ((<= i 0) \"\")\n"
    "            ((char=? (string-ref base i) #\\.) (substring base (+ i 1) (string-length base)))\n"
    "            (else (loop (- i 1)))))))\n"
    "\n"
    "(define (path-with-extension path extension)\n"
    "  (let* ((base (path-basename path))\n"
    "         (dir (path-directory path))\n"
    "         (stem\n"
    "          (let loop ((i (- (string-length base) 1)))\n"
    "            (cond ((<= i 0) base)\n"
    "                  ((char=? (string-ref base i) #\\.) (substring base 0 i))\n"
    "                  (else (loop (- i 1)))))))\n"
    "    (path-join dir\n"
    "               (string-append stem\n"
    "                              (if (and (> (string-length extension) 0)\n"
    "                                       (not (char=? (string-ref extension 0) #\\.)))\n"
    "                                  \".\"\n"
    "                                  \"\")\n"
    "                              extension))))\n"
    "\n"
    "(define *supported-r7rs-environments*\n"
    "  '((scheme base)\n"
    "    (scheme case-lambda)\n"
    "    (scheme char)\n"
    "    (scheme complex)\n"
    "    (scheme cxr)\n"
    "    (scheme eval)\n"
    "    (scheme file)\n"
    "    (scheme inexact)\n"
    "    (scheme lazy)\n"
    "    (scheme load)\n"
    "    (scheme process-context)\n"
    "    (scheme read)\n"
    "    (scheme repl)\n"
    "    (scheme sort)\n"
    "    (scheme time)\n"
    "    (scheme write)))\n"
    "\n"
    "(define (%valid-r7rs-import-identifiers? identifiers)\n"
    "  (and (pair? identifiers)\n"
    "       (proper-list? identifiers)\n"
    "       (every symbol? identifiers)))\n"
    "\n"
    "(define (%valid-r7rs-rename-list? renames)\n"
    "  (and (pair? renames)\n"
    "       (proper-list? renames)\n"
    "       (every (lambda (rename)\n"
    "                (and (proper-list? rename)\n"
    "                     (= (length rename) 2)\n"
    "                     (symbol? (car rename))\n"
    "                     (symbol? (cadr rename))))\n"
    "              renames)))\n"
    "\n"
    "(define (supported-r7rs-environment? spec)\n"
    "  (cond\n"
    "    ((member spec *supported-r7rs-environments*) #t)\n"
    "    ((not (pair? spec)) #f)\n"
    "    ((eq? (car spec) 'only)\n"
    "     (and (pair? (cdr spec))\n"
    "          (%valid-r7rs-import-identifiers? (cddr spec))\n"
    "          (supported-r7rs-environment? (cadr spec))))\n"
    "    ((eq? (car spec) 'except)\n"
    "     (and (pair? (cdr spec))\n"
    "          (%valid-r7rs-import-identifiers? (cddr spec))\n"
    "          (supported-r7rs-environment? (cadr spec))))\n"
    "    ((eq? (car spec) 'prefix)\n"
    "     (and (pair? (cdr spec))\n"
    "          (pair? (cddr spec))\n"
    "          (null? (cdddr spec))\n"
    "          (symbol? (caddr spec))\n"
    "          (supported-r7rs-environment? (cadr spec))))\n"
    "    ((eq? (car spec) 'rename)\n"
    "     (and (pair? (cdr spec))\n"
    "          (%valid-r7rs-rename-list? (cddr spec))\n"
    "          (supported-r7rs-environment? (cadr spec))))\n"
    "    (else #f)))\n"
    "\n"
    "(define (environment . specs)\n"
    "  ;; R7RS constructs the result from an empty environment before importing\n"
    "  ;; the requested libraries.  With no import sets, do not leak the mutable\n"
    "  ;; interaction environment into eval.\n"
    "  (if (null? specs)\n"
    "      (null-environment 5)\n"
    "      (begin\n"
    "        (for-each\n"
    "          (lambda (spec)\n"
    "            (if (not (supported-r7rs-environment? spec))\n"
    "                (error \"environment: unsupported library specifier\" spec)))\n"
    "          specs)\n"
    "        (%r7rs-environment specs))))\n"
    "\n"
    "(define-syntax import\n"
    "  (syntax-rules ()\n"
    "    ((import spec ...)\n"
    "     (begin))))\n"
    "\n"
    "(define-syntax define-library\n"
    "  (syntax-rules (export import begin include include-ci)\n"
    "    ((define-library name)\n"
    "     (begin))\n"
    "    ((define-library name (export export-spec ...) clause ...)\n"
    "     (define-library name clause ...))\n"
    "    ((define-library name (import import-spec ...) clause ...)\n"
    "     (define-library name clause ...))\n"
    "    ((define-library name (begin body ...) clause ...)\n"
    "     (begin body ... (define-library name clause ...)))\n"
    "    ((define-library name (include filename ...) clause ...)\n"
    "     (begin (include filename ...) (define-library name clause ...)))\n"
    "    ((define-library name (include-ci filename ...) clause ...)\n"
    "     (begin (include-ci filename ...) (define-library name clause ...)))))\n"
    "\n"
    "(define-syntax include\n"
    "  (syntax-rules ()\n"
    "    ((include filename ...)\n"
    "     (begin (load filename) ...))))\n"
    "\n"
    "(define-syntax include-ci\n"
    "  (syntax-rules ()\n"
    "    ((include-ci filename ...)\n"
    "     (include filename ...))))\n"
    "\n"
    "(define-syntax letrec*\n"
    "  (syntax-rules ()\n"
    "    ((letrec* ((var init) ...) body ...)\n"
    "     (let ((var #f) ...)\n"
    "       (set! var init) ...\n"
    "       body ...))))\n"
    "\n"
    "(define (list-set! lst k obj)\n"
    "  (set-car! (list-tail lst k) obj))\n"
    "\n"
    "(define (port? obj)\n"
    "  (or (input-port? obj) (output-port? obj)))\n"
    "\n"
    "(define (i/o-port? obj)\n"
    "  (and (input-port? obj) (output-port? obj)))\n"
    "\n"
    "(define (square x)\n"
    "  (* x x))\n"
    "\n"
    "(define (string->vector str . rest)\n"
    "  (if (> (length rest) 2)\n"
    "      (error \"string->vector: too many arguments\"))\n"
    "  (let* ((start (if (null? rest) 0 (car rest)))\n"
    "         (end (if (or (null? rest) (null? (cdr rest)))\n"
    "                  (string-length str)\n"
    "                  (cadr rest))))\n"
    "    (%require-string-range \"string->vector\" str start end)\n"
    "    (let ((vec (make-vector (- end start))))\n"
    "    (let loop ((i start) (j 0))\n"
    "      (if (< i end)\n"
    "          (begin\n"
    "            (vector-set! vec j (string-ref str i))\n"
    "            (loop (+ i 1) (+ j 1)))\n"
    "          vec)))))\n"
    "\n"
    "(define (symbol=? first second . rest)\n"
    "  (and (symbol? first)\n"
    "       (symbol? second)\n"
    "       (eq? first second)\n"
    "       (let loop ((xs rest))\n"
    "         (or (null? xs)\n"
    "             (and (symbol? (car xs))\n"
    "                  (eq? first (car xs))\n"
    "                  (loop (cdr xs)))))))\n"
    "\n"
    "(define (vector->string vec . rest)\n"
    "  (if (> (length rest) 2)\n"
    "      (error \"vector->string: too many arguments\"))\n"
    "  (let* ((start (if (null? rest) 0 (car rest)))\n"
    "         (end (if (or (null? rest) (null? (cdr rest)))\n"
    "                  (vector-length vec)\n"
    "                  (cadr rest))))\n"
    "    (%require-vector-range \"vector->string\" vec start end)\n"
    "    (let ((str (make-string (- end start))))\n"
    "    (let loop ((i start) (j 0))\n"
    "      (if (< i end)\n"
    "          (begin\n"
    "            (string-set! str j (vector-ref vec i))\n"
    "            (loop (+ i 1) (+ j 1)))\n"
    "          str)))))\n"
    "\n"
    ";;; ============================================================================\n"
    ";;; SRFI-2: and-let* (guarded evaluation)\n"
    ";;; ============================================================================\n"
    "\n"
    ";; (and-let* ((var expr) ...) body ...)\n"
    ";; Sequential binding with short-circuit on #f\n"
    "(define-syntax and-let*\n"
    "  (syntax-rules ()\n"
    "    ;; No bindings, just body\n"
    "    ((and-let* () body ...)\n"
    "     (begin body ...))\n"
    "    ;; No bindings, no body -> #t\n"
    "    ((and-let* ())\n"
    "     #t)\n"
    "    ;; Binding without variable (just test)\n"
    "    ((and-let* ((expr) more ...) body ...)\n"
    "     (if expr\n"
    "         (and-let* (more ...) body ...)\n"
    "         #f))\n"
    "    ;; Binding with variable\n"
    "    ((and-let* ((var expr) more ...) body ...)\n"
    "     (let ((var expr))\n"
    "       (if var\n"
    "           (and-let* (more ...) body ...)\n"
    "           #f)))))\n"
;
static const size_t stdlib_scm_len = sizeof(stdlib_scm) - 1;