pub const SOURCE: &str = "; The object-level evaluator, in CPS so that a continuation is an ordinary\n; object value a reflective procedure can be handed. What it interprets is the\n; floor\'s grammar, the surface rewrite having already run.\n;\n; value = number | symbol | nil | pair | floor closure | code\n; | (\'clo self param body env . m)\n; | (\'rclo params body env . m)\n; | (\'cfun . f) f a floor closure: a compiled object function,\n; tagged so a call site can tell it from a primitive\n; | (\'cont f . h) f, h floor closures of one argument: what to do\n; with a value, and with what a raise carried\n; env = list of frames, a frame an immutable assoc list\n; m = an interpreter: an assoc list from handler name to handler, passed\n; to every handler as its self parameter, so the recursion is open.\n; A handler that is an object closure is interpreted by the `m` it\n; closed over - which is the meta level, materialized by having been\n; written. The tower is the closure chain: no counter, no stack.\n; l = what the specializer knows: `concrete-l`, or `(staged-l frames)`\n; for a region being compiled with those closures unfolding into it\n\n; \u{2500}\u{2500} data \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n(define (cadr x) (car (cdr x)))\n(define (caddr x) (car (cdr (cdr x))))\n(define (cadddr x) (car (cdr (cdr (cdr x)))))\n\n(define (length xs) (if (nil? xs) 0 (+ 1 (length (cdr xs)))))\n\n; `assq` is a host op (`src/floor/host.rs`), the one place the floor grew for\n; speed rather than reach: written here it is a recursive closure, and a closure\n; entry allocates, so a frame of a hundred names cost a hundred allocations to\n; miss.\n\n(define (tagged? v t) (and (pair? v) (eq? (car v) t)))\n\n; `pair?` residualizes when handed code and a residual condition reifies both\n; branches, so a tag test on a maybe-staged value settles the code case first.\n(define (has-tag? v t) (if (code? 0 v) 0 (tagged? v t)))\n\n; \u{2500}\u{2500} continuations \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n; Two arms because a computation has two ways to end, so an error walks the\n; object-level stack as a value does. Letting the floor unwind instead would\n; delimit continuations by floor frames: a protected region could not then be\n; suspended inside.\n(define (cont f h) (cons \'cont (cons f h)))\n(define (cont-norm k) (car (cdr k)))\n(define (cont-raise k) (cdr (cdr k)))\n\n; The raise arm is inherited unchanged, which is what makes the arms a stack\n; rather than a per-frame decision.\n(define (cont-in k f) (cont f (cont-raise k)))\n\n; A raise arriving here is re-thrown, so it leaves as a floor value and lands\n; where the floor\'s discipline puts it: the argument position of whichever\n; `apply-cont` was waiting on this result.\n(define id-cont (cont (lambda (v) v) (lambda (v) (throw v))))\n\n; The test is `raise?`, and that is the point of `raise?` having no code arm:\n; while this evaluator compiles, every value it handles is a residual, the test\n; folds to false, and none of this conditional survives into what is emitted.\n; Compiled code carries no handler chain and gets the floor\'s discipline free.\n(define (apply-cont k v)\n (if (tagged? k \'cont)\n (if (raise? v)\n ((cont-raise k) (raise-value v))\n ((cont-norm k) v))\n (throw (cons \'not-a-continuation k))))\n\n; \u{2500}\u{2500} environments \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n(define (env-get env name)\n (if (nil? env)\n (throw (cons \'unbound name))\n (let ((hit (assq name (car env))))\n (if (pair? hit) (cdr hit) (env-get (cdr env) name)))))\n\n(define (env-extend env name val)\n (cons (cons (cons name val) \'()) env))\n\n; Names and values run out together or the arity was wrong; reporting it here\n; keeps every applier from checking first.\n(define (bind-all env names vals)\n (cond ((nil? names)\n (if (nil? vals) env (throw (cons \'arity vals))))\n ((nil? vals) (throw (cons \'arity names)))\n (else (bind-all (env-extend env (car names) (car vals))\n (cdr names) (cdr vals)))))\n\n; \u{2500}\u{2500} closures \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n; A closure carries the interpreter in force where it was written, so applying\n; it runs its own semantics rather than the caller\'s.\n(define (clo self params body env m)\n (cons \'clo (cons self (cons params (cons body (cons env m))))))\n\n(define (clo-self c) (cadr c))\n(define (clo-params c) (caddr c))\n(define (clo-body c) (cadddr c))\n(define (clo-env c) (car (cdr (cdr (cdr (cdr c))))))\n(define (clo-m c) (cdr (cdr (cdr (cdr (cdr c))))))\n\n; Self before the parameters, so a parameter of the same name shadows it.\n(define (clo-frame f as)\n (bind-all (env-extend (clo-env f) (clo-self f) f) (clo-params f) as))\n\n; Its parameters are the reification of one call site, which arrives whole or\n; not at all, so its arity is five whatever the call it reifies had.\n(define (rclo params body env m)\n (cons \'rclo (cons params (cons body (cons env m)))))\n\n(define (rclo-params c) (cadr c))\n(define (rclo-body c) (caddr c))\n(define (rclo-env c) (cadddr c))\n(define (rclo-m c) (cdr (cdr (cdr (cdr c)))))\n\n; A compiled object function: the floor closure `run` gave back, wrapped so a\n; call site can tell it from the floor closures the base environment binds the\n; primitives to. It carries no `m` - its semantics were spent compiling it, and\n; that is what compiling costs.\n(define (cfun f) (cons \'cfun f))\n(define (cfun-fn c) (cdr c))\n\n; Every other way of altering semantics is built from these two: which\n; interpreter a procedure runs under is a field of it, not a property of where\n; it is called. Replacing it rebuilds the closure, so the self name binds the\n; new one and a recursive call does not fall back to the old semantics.\n(define (interp-of f)\n (cond ((tagged? f \'clo) (clo-m f))\n ((tagged? f \'rclo) (rclo-m f))\n (else (throw (cons \'no-interpreter f)))))\n\n(define (with-interp f m)\n (cond ((tagged? f \'clo)\n (clo (clo-self f) (clo-params f) (clo-body f) (clo-env f) m))\n ((tagged? f \'rclo)\n (rclo (rclo-params f) (rclo-body f) (rclo-env f) m))\n (else (throw (cons \'no-interpreter f)))))\n\n; \u{2500}\u{2500} the stage dictionary \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n; Nothing here decides *whether* a value belongs in the residual: that is\n; decided by what the value meets, which is a floor operation. An evaluator\n; written over those operations is stage-polymorphic without saying so, which is\n; why the three base handlers below call none of this.\n;\n; What is left is one piece of state, concrete or staged with a stack of the\n; closures the region is unfolding into itself, innermost first. The stack rides\n; here rather than in a cell because it is a dynamic extent in a CPS evaluator:\n; the entry is gone again in the continuation, which was built one level out, so\n; a captured continuation restores it where a cell would not.\n;\n; `(l \'lift)` is derived rather than carried, which is why there is one\n; constructor per state and not one per answer. It is for a handler that wants a\n; value in the residual that nothing at the site would have put there. An\n; annotation and not a rule: it will cons a pair or \u{3b7}-expand a closure, because\n; a program that writes it has asked for that.\n(define (lift-code v) (lift v))\n\n(define (keep-code v) v)\n\n(define (concrete-l sel)\n (cond ((eq? sel \'staged) 0)\n ((eq? sel \'lift) keep-code)\n (else \'())))\n\n; Compiling with nothing unfolded yet is `(staged-l \'())` - an empty stack,\n; not a third state.\n(define (staged-l frames)\n (lambda (sel)\n (cond ((eq? sel \'staged) 1)\n ((eq? sel \'lift) lift-code)\n (else frames))))\n\n; \u{2500}\u{2500} interpreters \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n(define (mget m name)\n (let ((hit (assq name m)))\n (if (pair? hit) (cdr hit) (throw (cons \'no-handler name)))))\n\n; Dispatch. A floor closure is applied by the floor; an object closure is\n; interpreted under the interpreter it closed over, so a level exists exactly\n; where a handler was written in the object language and the regress stops where\n; the handlers stop being object closures.\n;\n; Levels do not share the dictionary. A handler is compiler code, running while\n; the level below is compiled, so it runs concretely and `l` reaches it as an\n; argument to emit through rather than as the stage it is evaluated at.\n;\n; The five arguments go in at once rather than through `static-apply`, which\n; would be the cycle `static-apply` is on the other side of.\n(define (meta m l name e r k)\n (let ((h (mget m name)))\n (if (has-tag? h \'clo)\n (meta (clo-m h) concrete-l \'base-eval (clo-body h)\n (clo-frame h (list m l e r k))\n (cont-in k (lambda (v) v)))\n (h m l e r k))))\n\n; \u{2500}\u{2500} application \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n; Equality that cannot tell one residual from another: what is code is whatever\n; the running program will put there, and no unfolding settles it. The code case\n; is asked first because `eq?` handed code residualizes, and a comparison that\n; asked later would emit its own answer into the program it is inspecting.\n;\n; `eq?` at every node is not only a fast path: a shared subtree is settled by it\n; alone, which keeps this proportional to the difference rather than to the size\n; of a closure\'s environment.\n(define (same-static? a b)\n (cond ((code? 0 a) (code? 0 b))\n ((code? 0 b) 0)\n ((eq? a b) 1)\n ((pair? a)\n (if (pair? b)\n (if (same-static? (car a) (car b))\n (same-static? (cdr a) (cdr b))\n 0)\n 0))\n (else 0)))\n\n; The cycle, or nil: the frame names from the repeat down to here, in call\n; order. A repeat is the same closure reached with static-equal arguments, which\n; is exactly when unfolding cannot stop - captured values are fixed, so only an\n; argument could make the next unfolding differ.\n;\n; Static arguments that do change are what this must not catch, and why a depth\n; limit is the wrong instrument: an interpreter staged against a static program\n; unfolds once per form in it, legitimately.\n(define (cycle-from here frames seen)\n (cond ((nil? frames) \'())\n ((same-static? here (car frames))\n (cons (clo-self (car (car frames))) seen))\n (else (cycle-from here (cdr frames)\n (cons (clo-self (car (car frames))) seen)))))\n\n; Applying an object closure while compiling unfolds it into the code being\n; emitted, which is what makes a compiled region fast and an interpreted\n; recursive callee not terminate.\n;\n; A self-call inside a `clambda` never reaches here - `lift-fun` binds the\n; function\'s own name to a code variable, so the call residualizes - and neither\n; does a call to something already compiled. What is left is a call from\n; compiled code into interpreted code.\n(define (inline-clo f as l k)\n (let ((here (cons f as)))\n (let ((cycle (cycle-from here (l \'inlining) \'())))\n (if (nil? cycle)\n (meta (clo-m f) (staged-l (cons here (l \'inlining)))\n \'base-eval (clo-body f) (clo-frame f as) k)\n (throw (cons \'inlines-forever cycle))))))\n\n; Carried across by reference rather than by structure, the only crossing that\n; works for every value: a closure and an interpreter cross intact, where\n; lifting would expand the first and refuse the second.\n(define (persist v) (if (code? 0 v) v (lift-ref 0 v)))\n\n(define (persist-all as)\n (if (nil? as) \'() (cons (persist (car as)) (persist-all (cdr as)))))\n\n; The calling convention, as a dispatch on how the operator is represented.\n; Staging resolves it, which is most of what makes a compiled region fast; the\n; first arm is the one that cannot resolve.\n;\n; A code operator means the call site is dynamic, but `code?` does not say the\n; operator will be something the floor can apply - it says the operator is\n; unknown. So the dispatch cannot be resolved and is instead emitted, and the\n; thing emitted is this cond. Where the floor does know a residual variable got\n; a lambda (the function\'s own name, a `clambda` in the same scope) the call is\n; direct. `concrete-l` because a call out of a compiled region stages nothing,\n; and `id-cont` because the residual\'s continuation is the floor\'s stack.\n;\n; Deciding at run time is what makes compiling an annotation rather than a\n; restriction: the callee names its semantics in `clo-m`, so an alteration made\n; after the caller was compiled is still seen. The one thing this cannot recover\n; is a reflective operator - `eval-app` decides from the operator\'s tag, code has\n; no tag, and by then the operands are values. That is the boundary of what\n; compiling preserves.\n(define (static-apply l f as k)\n (cond ((code? 0 f)\n (if (code-fun? f)\n (apply-cont k (apply f as))\n (apply-cont k (apply (lift-ref 0 static-apply)\n (list (lift-ref 0 concrete-l)\n f\n (lift (persist-all as))\n (lift-ref 0 id-cont))))))\n ((tagged? f \'clo)\n (if (l \'staged)\n (inline-clo f as l k)\n (meta (clo-m f) l \'base-eval (clo-body f) (clo-frame f as) k)))\n ((tagged? f \'rclo) (throw (cons \'no-call-site f)))\n ((tagged? f \'cont) (apply-cont f (car as)))\n ; Already compiled, so there is nothing to gain by unfolding it again\n ; and no reason to think that terminates: a recursive one does not.\n ; Staged, the call is emitted against the closure itself, which is the\n ; same cross-stage persistence the first arm uses on its operands.\n ;\n ; Below `clo` because an interpreted call is the hot one and `tagged?`\n ; is a closure entry, so an arm ahead of it costs an allocation on every\n ; application in the language.\n ((tagged? f \'cfun)\n (if (l \'staged)\n (apply-cont k (apply (lift-ref 0 (cfun-fn f)) (persist-all as)))\n (apply-cont k (apply (cfun-fn f) as))))\n ((num? f) (throw (cons \'cannot-apply f)))\n ((sym? f) (throw (cons \'cannot-apply f)))\n ((nil? f) (throw (cons \'cannot-apply f)))\n ((pair? f) (throw (cons \'cannot-apply f)))\n (else (apply-cont k (apply f as)))))\n\n; \u{2500}\u{2500} handlers \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n; None of the three moves anything to code: a constant stays one until it\n; reaches somewhere staged, and the floor decides that. Lifting here would guess\n; from the value alone, and the guess is wrong in both directions - it makes a\n; static list unwalkable by staging its `nil`, and stages nothing at all for a\n; constant a primitive computed.\n(define (eval-lit m l e r k) (apply-cont k e))\n\n(define (eval-var m l e r k) (apply-cont k (env-get r e)))\n\n(define (eval-quote m l e r k) (apply-cont k (cadr e)))\n\n; One `if` covers both stages: a code condition makes the floor\'s `if` reify\n; each branch into its own block, a staging-time one makes it choose. The\n; continuation is duplicated into both branches, which is what staging costs.\n(define (eval-if m l e r k)\n (meta m l \'base-eval (cadr e) r\n (cont-in k (lambda (c)\n (if c\n (meta m l \'base-eval (caddr e) r k)\n (meta m l \'base-eval (cadddr e) r k))))))\n\n(define (eval-lambda m l e r k)\n (let ((b (cadr e)))\n (apply-cont k (clo (car b) (cdr b) (caddr e) r m))))\n\n(define (eval-rlambda m l e r k)\n (apply-cont k (rclo (cadr e) (caddr e) r m)))\n\n; A handler for its own call site: it takes the five things a handler does, and\n; the two arriving unevaluated - operand syntax and continuation - are what make\n; it reflective. Its body runs at the meta level, so reaching the call site is\n; what `k` is for.\n;\n; Not `id-cont`: a body that raises has raised at the call site, so the raise arm\n; is the call site\'s. The normal arm still ends here, which is what lets a\n; reflective procedure answer without going through `k` - `abort` is that.\n(define (apply-reflective f m l es r k)\n (meta (rclo-m f) concrete-l \'base-eval (rclo-body f)\n (bind-all (rclo-env f) (rclo-params f) (list m l es r k))\n (cont (lambda (v) v) (cont-raise k))))\n\n(define (eval-let m l e r k)\n (let ((b (cadr e)))\n (meta m l \'base-eval (cadr b) r\n (cont-in k (lambda (v)\n (meta m l \'base-eval (caddr e)\n (env-extend r (car b) v) k))))))\n\n; `let`, but extending the environment by a frame rather than a name. That is\n; the whole of what a module is, and why importing is a form the evaluator knows\n; rather than a loader beside it: a frame\'s names are not known until the frame\n; exists, so no rewriting pass could have done this first.\n(define (eval-import m l e r k)\n (meta m l \'base-eval (cadr e) r\n (cont-in k (lambda (f)\n (meta m l \'base-eval (caddr e) (cons f r) k)))))\n\n; How many operands there are is the call\'s business rather than the function\'s,\n; so nothing here knows the operator\'s arity - `bind-all` finds a mismatch.\n(define (eval-args m l es r k)\n (if (nil? es)\n (apply-cont k \'())\n (meta m l \'base-eval (car es) r\n (cont-in k (lambda (v)\n (meta m l \'eval-args (cdr es) r\n (cont-in k (lambda (vs)\n (apply-cont k (cons v vs))))))))))\n\n; The operator is evaluated first, so whether the operands are evaluated at all\n; is decided with its value in hand. A reflective operator is therefore resolved\n; statically for free: a read of an immutable binding folds to the value, so an\n; `rclo` is still an `rclo` at staging time.\n(define (eval-app m l e r k)\n (meta m l \'base-eval (car e) r\n (cont-in k (lambda (f)\n (if (has-tag? f \'rclo)\n (apply-reflective f m l (cdr e) r k)\n (meta m l \'eval-args (cdr e) r\n (cont-in k (lambda (as)\n (static-apply l f as k)))))))))\n\n; Explicit compilation. `lift-fun` eta-expands into a residual lambda over the\n; object function\'s own name and its parameters, and binding the object names to\n; those code variables is what turns the body\'s recursion into a residual call\n; rather than an unfolding. The arity is the object function\'s, which is why\n; this is `lift-fun` and not a `lift` of a floor lambda.\n;\n; The lift happens inside `run` because `run` sets the level residual variables\n; count from - hence the thunk. The inline stack carries over rather than\n; starting again: a nested `clambda` is a second region but not a second\n; staging, and resetting here would hide a cycle through it.\n;\n; Staged, the answer stays code and a caller in the same region emits a direct\n; call to it. Run, it is a floor closure, which is indistinguishable from a\n; primitive - and a primitive applied to code is meant to unfold, where this is\n; meant to be called. `cfun` is that distinction, made here because it cannot be\n; recovered from the value later.\n(define (eval-clambda m l e r k)\n (let ((b (cadr e)))\n (let ((sl (staged-l (l \'inlining))))\n (let ((mk (lambda (u)\n (lift-fun (length (cdr b))\n (lambda f (vs)\n (meta m sl \'base-eval (caddr e)\n (bind-all (env-extend r (car b) (car vs))\n (cdr b) (cdr vs))\n id-cont))))))\n (apply-cont k (if (l \'staged) (mk 0) (cfun (run 0 (mk 0)))))))))\n\n(define (base-eval m l e r k)\n (cond ((num? e) (meta m l \'eval-lit e r k))\n ((nil? e) (meta m l \'eval-lit e r k))\n ((sym? e) (meta m l \'eval-var e r k))\n ((pair? e)\n (let ((h (car e)))\n (cond ((eq? h \'quote) (meta m l \'eval-quote e r k))\n ((eq? h \'if) (meta m l \'eval-if e r k))\n ((eq? h \'lambda) (meta m l \'eval-lambda e r k))\n ((eq? h \'rlambda) (meta m l \'eval-rlambda e r k))\n ((eq? h \'clambda) (meta m l \'eval-clambda e r k))\n ((eq? h \'let) (meta m l \'eval-let e r k))\n ((eq? h \'import) (meta m l \'eval-import e r k))\n (else (meta m l \'eval-app e r k)))))\n (else (meta m l \'eval-lit e r k))))\n\n(define base-m\n (list (cons \'base-eval base-eval)\n (cons \'eval-lit eval-lit)\n (cons \'eval-var eval-var)\n (cons \'eval-quote eval-quote)\n (cons \'eval-if eval-if)\n (cons \'eval-lambda eval-lambda)\n (cons \'eval-rlambda eval-rlambda)\n (cons \'eval-clambda eval-clambda)\n (cons \'eval-let eval-let)\n (cons \'eval-import eval-import)\n (cons \'eval-args eval-args)\n (cons \'eval-app eval-app)))\n\n; \u{2500}\u{2500} the base environment \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\n\n; Ends at `id-cont` because an arm is the end of a computation rather than a\n; step in one: what it answers is the answer.\n(define (wrap-arm f)\n (lambda (v) (static-apply concrete-l f (list v) id-cont)))\n\n; Primitives are floor closures, so they residualize by the floor\'s staging rule.\n; There is no primitive representation and no primitive apply.\n(define base-env\n (list (list (cons \'+ (lambda (a b) (+ a b)))\n (cons \'- (lambda (a b) (- a b)))\n (cons \'* (lambda (a b) (* a b)))\n (cons \'/ (lambda (a b) (/ a b)))\n (cons \'% (lambda (a b) (% a b)))\n (cons \'< (lambda (a b) (< a b)))\n (cons \'eq? (lambda (a b) (eq? a b)))\n (cons \'cons (lambda (a b) (cons a b)))\n (cons \'car (lambda (a) (car a)))\n (cons \'cdr (lambda (a) (cdr a)))\n (cons \'num? (lambda (a) (num? a)))\n (cons \'sym? (lambda (a) (sym? a)))\n (cons \'nil? (lambda (a) (nil? a)))\n (cons \'pair? (lambda (a) (pair? a)))\n (cons \'throw (lambda (a) (throw a)))\n ; A task\'s only way out is a message, so the object language needs\n ; no more of the scheduler than this.\n (cons \'send (lambda (a b) (send a b)))\n (cons \'receive (lambda () (receive)))\n (cons \'monitor (lambda (a) (monitor a)))\n ; Imposed on a child rather than chosen by one: what it catches is\n ; a task whose failure cannot be reported without evaluating.\n (cons \'limit-turns (lambda (a n) (limit-turns a n)))\n ; The scheduler gets a floor closure that applies the object\n ; procedure, and it carries the interpreter the procedure was\n ; written under - which is how a task inherits a tower.\n (cons \'spawn (lambda (f)\n (spawn (lambda (me)\n (static-apply concrete-l f (list me) id-cont)))))\n ; One act is one step: a turn cannot end between the halves, so a\n ; child cannot die unwatched.\n (cons \'spawn-monitor\n (lambda (f)\n (spawn-monitor (lambda (me)\n (static-apply concrete-l f (list me) id-cont)))))\n ; Source rewriting, so the object language can read its own text.\n ; All data to data, which is why they are ops.\n (cons \'read (lambda (a) (read a)))\n (cons \'desugar (lambda (a) (desugar a)))\n (cons \'desugar-body (lambda (a) (desugar-body a)))\n (cons \'show (lambda (a) (show a)))\n ; Wrapped for the reason the arithmetic above is: an op is a floor\n ; form and a binding must hold a value.\n (cons \'str-append (lambda (a b) (str-append a b)))\n (cons \'str-len (lambda (a) (str-len a)))\n (cons \'sym->str (lambda (a) (sym->str a)))\n (cons \'str->sym (lambda (a) (str->sym a)))\n (cons \'substr (lambda (a b c) (substr a b c)))\n (cons \'str->num (lambda (a) (str->num a)))\n (cons \'str-upper (lambda (a) (str-upper a)))\n (cons \'str-lower (lambda (a) (str-lower a)))\n (cons \'ord (lambda (a) (ord a)))\n (cons \'chr (lambda (a) (chr a)))\n (cons \'assq (lambda (a b) (assq a b)))\n (cons \'sqrt (lambda (a) (sqrt a)))\n (cons \'exp (lambda (a) (exp a)))\n (cons \'log (lambda (a) (log a)))\n (cons \'sin (lambda (a) (sin a)))\n (cons \'cos (lambda (a) (cos a)))\n (cons \'tan (lambda (a) (tan a)))\n (cons \'asin (lambda (a) (asin a)))\n (cons \'acos (lambda (a) (acos a)))\n (cons \'atan (lambda (a) (atan a)))\n (cons \'pow (lambda (a b) (pow a b)))\n (cons \'atan2 (lambda (a b) (atan2 a b)))\n (cons \'floor (lambda (a) (floor a)))\n (cons \'ceil (lambda (a) (ceil a)))\n (cons \'round (lambda (a) (round a)))\n (cons \'trunc (lambda (a) (trunc a)))\n ; What a reflective body works with: the evaluator\'s own functions\n ; under their own names. At the meta level the interpreter is not\n ; something to escape into, it is what is in scope.\n (cons \'meta meta)\n ; The wrapper is what makes an object function into an arm: an arm\n ; must be applicable by the floor, and an object closure is not.\n (cons \'cont (lambda (f h)\n (cont (wrap-arm f) (wrap-arm h))))\n ; The common case: every continuation the prelude builds is this,\n ; since `prompt` and `call/cc` delimit the continuation rather than\n ; the handler chain.\n (cons \'cont-in (lambda (k f)\n (cont (wrap-arm f) (cont-raise k))))\n ; `spawn-with` and `become` are prelude built from these; nothing\n ; else is needed, an interpreter being an assoc list.\n (cons \'interp-of interp-of)\n (cons \'with-interp with-interp)\n (cons \'apply-cont apply-cont)\n ; The other arm, reached deliberately. `(k (throw v))` cannot do\n ; it: the evaluator propagates the raise at the call site rather\n ; than delivering it as an argument. Resuming someone else\'s\n ; suspended computation with a failure is what wants this.\n (cons \'throw-to (lambda (k v) ((cont-raise k) v)))\n (cons \'apply static-apply)\n ; Applying something under it is what makes a delimiter, so the\n ; prelude needs it by name.\n (cons \'id-cont id-cont)\n (cons \'env-extend env-extend))))\n\n; What escapes this file. The interpreter and environment are arguments rather\n; than defaults because both are values a caller accumulates.\n(lambda (sel)\n (cond ((eq? sel \'eval)\n (lambda (m r e) (meta m concrete-l \'base-eval e r id-cont)))\n ((eq? sel \'compile)\n (lambda (m r e) (meta m (staged-l \'()) \'base-eval e r id-cont)))\n ; The floor closure a scheduler starts, evaluating `e` with the address\n ; the task was given in scope.\n ((eq? sel \'task)\n (lambda (m r e)\n (lambda (self)\n (meta m concrete-l \'base-eval e (env-extend r \'self self) id-cont))))\n ((eq? sel \'m) base-m)\n ((eq? sel \'env) base-env)\n (else (throw (cons \'no-export sel)))))\n";