pub const PRELUDE: &str = "; The object language\'s own library, evaluated by the tower at load time. None\n; of it is a form the evaluator knows: `call/cc`, the delimiter and the RPC are\n; definitions, and all they need beyond an ordinary function is to be handed\n; their call site. The file\'s value is one environment frame.\n\n; `=` is numeric and `eq?` is not: `<` raises on anything that is not a number\n; and `=` inherits that, which buys a whole number and a float standing for the\n; same quantity comparing equal.\n\n(define (not x) (if x 0 1))\n(define (> a b) (< b a))\n(define (<= a b) (not (< b a)))\n(define (>= a b) (not (< a b)))\n(define (= a b) (and (not (< a b)) (not (< b a))))\n\n; `%` follows the sign of its left argument, which is what makes `even?` a\n; comparison against zero rather than against one.\n\n(define (abs x) (if (< x 0) (- 0 x) x))\n(define (min a b) (if (< a b) a b))\n(define (max a b) (if (< a b) b a))\n(define (even? n) (eq? (% n 2) 0))\n(define (odd? n) (not (even? n)))\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 (tagged? v t) (and (pair? v) (eq? (car v) t)))\n\n; A bare symbol is its own verb, so `(\'keys)` and `\'keys` reach the same `case`\n; clause and a caller need not know which spelling a nullary verb takes.\n(define (verb v) (if (pair? v) (car v) v))\n\n; `fold` is the left one and takes the accumulator first, so it reads in the\n; order it runs; `foldr` is the one that rebuilds a list.\n\n(define (length xs) (if (nil? xs) 0 (+ 1 (length (cdr xs)))))\n\n(define (append xs ys)\n (if (nil? xs) ys (cons (car xs) (append (cdr xs) ys))))\n\n(define (fold f acc xs)\n (if (nil? xs) acc (fold f (f acc (car xs)) (cdr xs))))\n\n(define (foldr f acc xs)\n (if (nil? xs) acc (f (car xs) (foldr f acc (cdr xs)))))\n\n(define (reverse xs) (fold (lambda (acc x) (cons x acc)) \'() xs))\n\n; The `let` is the reason this is not a `foldr`: an argument is evaluated\n; before the call it belongs to, so a `foldr` runs the effects back to front.\n(define (map f xs)\n (if (nil? xs)\n \'()\n (let ((y (f (car xs)))) (cons y (map f (cdr xs))))))\n\n(define (filter p xs)\n (if (nil? xs)\n \'()\n (let ((keep (p (car xs))))\n (if keep\n (cons (car xs) (filter p (cdr xs)))\n (filter p (cdr xs))))))\n\n; A raise past the end rather than nil: nil is a value a list can hold. The\n; inner loop is what lets the raise carry the index the caller asked for.\n(define (nth n xs)\n (let ((walk\n (lambda walk (i ys)\n (cond ((nil? ys) (throw (cons \'no-such-index n)))\n ((eq? i 0) (car ys))\n (else (walk (- i 1) (cdr ys)))))))\n (walk n xs)))\n\n(define (last xs)\n (cond ((nil? xs) (throw \'empty-list))\n ((nil? (cdr xs)) (car xs))\n (else (last (cdr xs)))))\n\n(define (assq name al)\n (cond ((nil? al) 0)\n ((eq? (car (car al)) name) (car al))\n (else (assq name (cdr al)))))\n\n(define (without name al)\n (cond ((nil? al) \'())\n ((eq? (car (car al)) name) (cdr al))\n (else (cons (car al) (without name (cdr al))))))\n\n(define (member? x xs)\n (cond ((nil? xs) 0)\n ((eq? (car xs) x) 1)\n (else (member? x (cdr xs)))))\n\n(define (drop-one x xs)\n (cond ((nil? xs) \'())\n ((eq? (car xs) x) (cdr xs))\n (else (cons (car xs) (drop-one x (cdr xs))))))\n\n(define (snoc x xs) (append xs (list x)))\n\n; A character is a one-character string, so `str-at` is a `substr` and the\n; comparisons are `eq?` like any other.\n\n(define (str-at s i) (substr s i 1))\n\n; Empty pieces are kept: dropping the field between two adjacent separators\n; would silently renumber every field after it.\n(define (split s sep)\n (let ((n (str-len s)))\n (let ((walk\n (lambda walk (i start)\n (cond ((eq? i n) (list (substr s start (- i start))))\n ((eq? (str-at s i) sep)\n (cons (substr s start (- i start)) (walk (+ i 1) (+ i 1))))\n (else (walk (+ i 1) start))))))\n (walk 0 0))))\n\n(define (join sep parts)\n (cond ((nil? parts) \"\")\n ((nil? (cdr parts)) (car parts))\n (else (str-append (car parts)\n (str-append sep (join sep (cdr parts)))))))\n\n; Answers `(str-len s)` on no match rather than a sentinel: every number is a\n; possible index, and zero - the only false one - means a match at the front.\n(define (str-find s needle)\n (let ((n (str-len s))\n (k (str-len needle))\n (walk (lambda walk (i)\n (cond ((< (- n i) k) n)\n ((eq? (substr s i k) needle) i)\n (else (walk (+ i 1)))))))\n (walk 0)))\n\n(define (str-has? s needle) (< (str-find s needle) (str-len s)))\n\n(define (starts-with? s p) (eq? (substr s 0 (str-len p)) p))\n\n; `substr` clamps, so a suffix longer than the string compares unequal rather\n; than raising on the negative index.\n(define (ends-with? s p)\n (let ((k (str-len p)))\n (eq? (substr s (- (str-len s) k) k) p)))\n\n(define (space? c) (or (eq? c \" \") (eq? c \"\\t\") (eq? c \"\\n\")))\n\n; A string that is all space leaves `to` behind `from`; the negative length\n; that makes is clamped to the empty string.\n(define (str-trim s)\n (let ((n (str-len s))\n (from (lambda from (i)\n (if (and (< i n) (space? (str-at s i))) (from (+ i 1)) i)))\n (to (lambda to (i)\n (if (and (< 0 i) (space? (str-at s (- i 1)))) (to (- i 1)) i)))\n (a (from 0)))\n (substr s a (- (to n) a))))\n\n; A raise rather than a report: a task\'s exit already carries the reason, and a\n; checking library that printed would be inventing a second channel for it.\n\n(define (assert ok why) (if ok \'ok (throw (cons \'assert-failed why))))\n\n(define (check what got want)\n (if (eq? got want) \'ok (throw `(check-failed ,what ,got ,want))))\n\n; The continuation of the call site, as a value: `k` is already there to hand\n; over, which is the whole of it.\n(define call/cc\n (lambda reflect (m l e r k)\n (meta m l \'base-eval (car e) r\n (cont-in k (lambda (f) (apply l f (list k) k))))))\n\n; A delimiter, reflective for the same reason it works: an ordinary function\n; would be applied under the caller\'s continuation, which is precisely the\n; continuation being delimited. It delimits continuations and not handlers - a\n; raise passes straight through, and `attempt` rather than this stops one.\n(define prompt\n (lambda reflect (m l e r k)\n (meta m l \'base-eval (car e) r\n (cont-in k (lambda (th) (apply-cont k (apply l th \'() id-cont)))))))\n\n; Nothing here touches `k`, so the value goes to the innermost prompt instead\n; of to the call site.\n(define abort\n (lambda reflect (m l e r k)\n (meta m l \'base-eval (car e) r id-cont)))\n\n; Suspend: the call site\'s continuation is reified and abandoned to whoever\n; runs the prompt, as a request it can resume later. One operand, with `call`\n; below assembling the pair - a reflective procedure is handed its operands as\n; syntax, so an n-ary one would be re-doing `eval-args` by hand.\n(define await\n (lambda reflect (m l e r k)\n (meta m l \'base-eval (car e) r\n (cont-in k (lambda ((to . body)) `(await ,to ,body ,k))))))\n\n; The extra field is read by the loop and nothing else: arming the timer needs\n; the call\'s id, which cannot be had from out here.\n(define await-in\n (lambda reflect (m l e r k)\n (meta m l \'base-eval (car e) r\n (cont-in k (lambda ((ms to . body))\n `(await ,to ,body ,k ,ms))))))\n\n; An RPC, and nothing blocks: the continuation reified here is the return from\n; `call`, resumed by the loop when the reply lands.\n(define (call to msg) (await (cons to msg)))\n\n; Giving up is not cancelling: the callee is still working, and its reply when\n; it comes is dropped by the loop the way a duplicate is. Nothing here can stop\n; a task that is not listening, and pretending otherwise makes a timeout a lie.\n(define (call-within ms to msg) (await-in (cons ms (cons to msg))))\n\n; Naming a capability grants nothing: this is the same message anyone could\n; send, and a world that registers no `stdout` makes it a raise.\n(define (say v) (call \'(host stdout) `(line ,v)))\n\n; A protected region: `(\'ok . v)` or `(\'throw . v)`, tagged because a raise\n; carries an ordinary value and a thrown `3` must be told from a returned one.\n; Being reflective is what keeps it from delimiting - both arms continue into\n; `k`, so a `call` inside one suspends the way it would anywhere else.\n(define attempt\n (lambda reflect (m l e r k)\n (meta m l \'base-eval (car e) r\n (cont-in k\n (lambda (th)\n (apply l th \'()\n (cont (lambda (v) (apply-cont k (cons \'ok v)))\n (lambda (v) (apply-cont k (cons \'throw v))))))))))\n\n; The interpreter in force here, as a value. One line, which is what the claim\n; amounts to: `m` is already an argument to every handler, so a reflective\n; procedure has only to hand it back.\n(define interpreter (lambda reflect (m l e r k) (apply-cont k m)))\n\n(define environment (lambda reflect (m l e r k) (apply-cont k r)))\n\n; A program and the environment to run it in, both values rather than syntax.\n; A file\'s definitions nest into the body that follows them, and a line typed\n; at a prompt has no body to nest into, so whoever reads the lines carries the\n; environment instead and hands it over here.\n(define eval-there\n (lambda reflect (m l e r k)\n (meta m l \'base-eval (car e) r\n (cont-in k (lambda (req)\n (meta m l \'base-eval (cdr req) (car req) k))))))\n\n(define (eval-in env prog) (eval-there (cons env prog)))\n\n(define (handler-of i name)\n (let ((hit (assq name i)))\n (if (pair? hit) (cdr hit) (throw (cons \'no-handler name)))))\n\n; In front rather than in place, so the one it shadows is still there to\n; be reached by an interpreter written over it.\n(define (with-handler i name h) (cons (cons name h) i))\n\n; The child runs `f` under `(M I)`, where `I` is the interpreter `f` was\n; written under; the spawner\'s own is untouched, so this forks rather than\n; shares.\n(define (spawn-with mut f) (spawn (with-interp f (mut (interp-of f)))))\n\n; The dispatch loop owns the only prompt in a task, which is what keeps `call`\n; honest: a continuation reified without one would include returning to the\n; loop and going on receiving, so resuming it later would leave two loops\n; running.\n;\n; `handler` answers with the next state, `(\'stop . v)` to end the task, or a\n; `become`. The loop reads `(\'reply id v)` and the deaths it asked about\n; itself; every other message is the handler\'s, `(\'req from id msg)` included.\n;\n; A pending call is `(id to . k)`. The callee is kept because a reply is not\n; the only way a call can end.\n\n(define (pend-to e) (cadr e))\n(define (pend-k e) (cdr (cdr e)))\n\n(define (waiting-on to pending)\n (cond ((nil? pending) 0)\n ((eq? (pend-to (car pending)) to) (car pending))\n (else (waiting-on to (cdr pending)))))\n\n; What a message is to the loop, rather than to the handler:\n;\n; (\'resume e . v) carry `v` into the call `e` is waiting on\n; (\'fail e . reason) carry a raise into it instead\n; \'drop the loop\'s own bookkeeping, and finished with\n; \'pass the handler\'s\n;\n; A reply with no waiter is dropped, which keeps the table finite. A death is\n; the loop\'s only if the loop asked about it, so watching a task and calling it\n; do not interfere.\n;\n; A reply of `(\'throw . why)` raises at the call site, which is what makes a\n; failed call fail; the cost is that `(\'throw . v)` cannot be returned as data\n; across an RPC, and a caller that wants the pair must wrap it.\n(define (classify msg pending watched)\n (cond ((tagged? msg \'reply)\n (let (((_ id v) msg)\n (e (assq id pending)))\n (cond ((not (pair? e)) \'drop)\n ((tagged? v \'throw) `(fail ,e ,(cdr v)))\n (else `(resume ,e ,v)))))\n ((and (tagged? msg \'task-down) (member? (cadr msg) watched))\n (let ((e (waiting-on (cadr msg) pending)))\n (if (pair? e) `(fail ,e (callee-down . ,(cdr msg))) \'drop)))\n (else \'pass)))\n\n; Asks and takes no for an answer, rather than deciding first whether the\n; address is one `monitor` will accept: an address is opaque here, and a loop\n; that tested its kind would need revisiting each time another kind became\n; watchable.\n(define (watch to seen)\n (if (member? to seen)\n seen\n (if (tagged? (attempt (lambda () (monitor to))) \'ok)\n (cons to seen)\n seen)))\n\n; The backlog is read before the mailbox, so a message that already waited once\n; is not overtaken by one that has just arrived.\n(define (next-msg pending backlog)\n (if (and (nil? pending) (pair? backlog))\n backlog\n (cons (receive) backlog)))\n\n(define (task-loop me handler state)\n (let ((spin\n (lambda spin (handler state id pending watched backlog)\n (let (((msg . waiting) (next-msg pending backlog))\n (what (classify msg pending watched)))\n ; One turn at a time: a second turn started beside a\n ; suspended one would work from the state that one still\n ; means to update, and whichever answered last would\n ; overwrite the other silently. A handler that wants to\n ; serve while a call is outstanding spawns a task to hold\n ; the call, putting that task\'s state at stake instead.\n (if (and (eq? what \'pass) (pair? pending))\n (spin handler state id pending watched (snoc msg waiting))\n ; Every arm that runs object code runs it under the\n ; prompt, so what comes back is a turn\'s answer and\n ; not a continuation of this loop.\n (let ((out (case (verb what)\n ((resume)\n (let (((_ e v) what))\n (prompt (lambda () ((pend-k e) v)))))\n ((fail)\n (let (((_ e v) what))\n (prompt (lambda () (throw-to (pend-k e) v)))))\n ((pass)\n (prompt (lambda ()\n (cons \'done (handler state msg)))))\n (else \'(skip)))))\n (let ((done (if (pair? what) (cadr what) 0))\n (rest (if (pair? done)\n (without (car done) pending)\n pending))\n ; A death answers one call, so if the callee\n ; owed more the message is handed back to\n ; ourselves for the next.\n (seen\n (if (tagged? msg \'task-down)\n (if (pair? (waiting-on (cadr msg) rest))\n (begin (send me msg) watched)\n (drop-one (cadr msg) watched))\n watched)))\n (case (verb out)\n ((skip)\n (spin handler state id rest seen waiting))\n ((done)\n (let ((next (cdr out)))\n (case (verb next)\n ((stop) (cdr next))\n ; The handler is rebuilt under the\n ; mutation, so the loop\'s own semantics\n ; are left alone.\n ((become)\n (spin (with-interp handler\n ((cadr next) (interp-of handler)))\n (caddr next) id rest seen waiting))\n ; A different handler entirely, and what\n ; waited goes with it: a task is\n ; addressable before it is ready to\n ; serve, so what was sent meanwhile is\n ; for what it became.\n ((hand)\n (spin (cadr next) (cdr (cdr next))\n id rest seen waiting))\n (else (spin handler next id rest seen waiting)))))\n ((await)\n ; One monitor per callee rather than per\n ; call, or a task calling the same peer\n ; would accumulate them forever.\n ;\n ; Watch before asking: the other order\n ; leaves a window where the monitor reports\n ; `noproc` about a task that died with\n ; something to say.\n ;\n ; Calling oneself is a deadlock, not a slow\n ; reply - the answer would have to come from\n ; the handler the call is suspended inside -\n ; so it is refused rather than parked, where\n ; it would look like a peer taking its time.\n ;\n ; The deadline timer needs no machinery here:\n ; it carries the id the real reply will, so\n ; whichever arrives second is dropped by the\n ; path a duplicate already takes.\n (let (((_ to body k . by) out))\n (if (eq? to me)\n (throw (cons \'self-call body))\n (let ((seen2 (watch to seen)))\n (begin\n (send to `(req ,me ,id ,body))\n (if (pair? by)\n (send \'(host clock)\n `(after ,(car by) ,me\n (reply ,id (throw . timeout))))\n \'ok)\n (spin handler state (+ id 1)\n (cons (cons id (cons to k)) rest)\n seen2 waiting))))))\n (else (throw (cons \'not-a-turn out)))))))))))\n (spin handler state 1 \'() \'() \'())))\n\n; A turn\'s answer that gives the task to another handler, with `state` to\n; go on from. What `become` is for semantics this is for behaviour: a task\'s\n; meaning and a task\'s job are separate things to replace.\n;\n; The loop\'s backlog survives it, which is what makes this more than a\n; convenience - a task is addressable from the moment it is spawned, so\n; requests that arrived before it was ready are answered by what it became.\n(define (hand handler state) (cons \'hand (cons handler state)))\n\n; A task that answers one message and ends: what a file run from a command line\n; is. The loop is still here because an RPC needs something to hold the\n; suspended continuation. A body ending in a `hand` is passed through rather\n; than stopped, so a file may spend itself setting up and then be something.\n(define (script me thunk)\n (task-loop me\n (lambda h (st msg)\n (let ((v (thunk)))\n (if (tagged? v \'hand) v (cons \'stop v))))\n \'()))\n\n; A request is `(\'req from id body)`.\n\n(define (req-from r) (cadr r))\n(define (req-id r) (caddr r))\n(define (req-body r) (cadddr r))\n\n; No address of its own: the id is the caller\'s, and the loop that made the\n; call is the only thing that knows what it meant.\n(define (reply req v) (send (req-from req) `(reply ,(req-id req) ,v)))\n\n; The tag is what `classify` reads, so this is not a convention between two\n; handlers - it is the same delivery a dead callee gets.\n(define (refuse req why) (reply req (cons \'throw why)))\n\n; A shape rather than a message: whoever asked has the ask itself back, and can\n; tell \"you do not do that\" from \"you do, and it went wrong\".\n(define (bad-request ask) (cons \'bad-request ask))\n\n; Nothing here is privileged: a supervisor is a dispatch loop whose state is a\n; list of children and whose handler answers `(\'task-down \u{2026})`. The deaths reach\n; it because the loop keeps only the monitors it set itself.\n;\n; A child is `(id addr limit stamps make)`. The last field is the whole of\n; \"restart restores initial state\" - there is no snapshot, because a spec is\n; not a state. The id, not the address, is what makes a restarted child the\n; same child: a restart is a new task and so a new address, which is why a\n; supervisor answers `(\'child id)` at all.\n\n(define (child-id c) (car c))\n(define (child-addr c) (cadr c))\n(define (child-limit c) (caddr c))\n(define (child-stamps c) (cadddr c))\n(define (child-make c) (nth 4 c))\n\n; Spawn and watch are one primitive: written separately, a turn ending between\n; them lets the child die before the watch lands, and the supervisor is told\n; `noproc` instead of what happened.\n(define (start-child id limit stamps make)\n (list id (spawn-monitor make) limit stamps make))\n\n; Specs are `(id limit . make)`.\n(define (start-all specs)\n (map (lambda (s) (start-child (car s) (cadr s) \'() (cdr (cdr s)))) specs))\n\n(define (find-child addr kids)\n (cond ((nil? kids) 0)\n ((eq? (child-addr (car kids)) addr) (car kids))\n (else (find-child addr (cdr kids)))))\n\n(define (child-named id kids)\n (cond ((nil? kids) 0)\n ((eq? (child-id (car kids)) id) (car kids))\n (else (child-named id (cdr kids)))))\n\n(define (drop-child addr kids)\n (cond ((nil? kids) \'())\n ((eq? (child-addr (car kids)) addr) (cdr kids))\n (else (cons (car kids) (drop-child addr (cdr kids))))))\n\n; A limit is a count of restarts left, or a rate `(n . ms)`. The count needs no\n; clock and stays the default for that reason: a tree built out of counts runs\n; in a world that registers no `clock`.\n(define (recent since stamps) (filter (lambda (t) (> t since)) stamps))\n\n; The child again, or 0 for \"that is enough\".\n(define (restart-child c)\n (let ((limit (child-limit c)))\n (if (pair? limit)\n (let ((now (call \'(host clock) \'(now))))\n (let ((fresh (cons now (recent (- now (cdr limit)) (child-stamps c)))))\n (if (> (length fresh) (car limit))\n 0\n (start-child (child-id c) limit fresh (child-make c)))))\n (if (eq? limit 0)\n 0\n (start-child (child-id c) (- limit 1) \'() (child-make c))))))\n\n; A child that raised is started again; a child that returned did what it was\n; for. That is OTP\'s *transient*, and the only one of the three needing no\n; extra field - the result already says which happened. A supervisor that has\n; spent its restarts, or has no children left, stops rather than park forever.\n;\n; (\'which-children) the `(id . addr)` pairs, as they are now\n; (\'child id) one address, or a raise\n(define (supervisor-turn kids msg)\n (case (verb msg)\n ((task-down)\n (let (((_ who . result) msg)\n (c (find-child who kids)))\n (if (pair? c)\n (let ((rest (drop-child who kids)))\n (cond ((tagged? result \'throw)\n (let ((again (restart-child c)))\n (if (pair? again)\n (cons again rest)\n (cons \'stop\n (cons \'give-up (cons (child-id c) result))))))\n ((nil? rest) (cons \'stop \'all-done))\n (else rest)))\n kids)))\n ((req)\n (let ((ask (req-body msg)))\n (case (verb ask)\n ((which-children)\n (begin (reply msg\n (map (lambda (c) (cons (child-id c) (child-addr c)))\n kids))\n kids))\n ((child)\n (let ((c (child-named (cadr ask) kids)))\n (begin (if (pair? c)\n (reply msg (child-addr c))\n (refuse msg (cons \'no-such-child (cadr ask))))\n kids)))\n (else (begin (refuse msg (bad-request ask)) kids)))))\n (else kids)))\n\n; Each spec is `(id limit . make)`. The children are started here rather than\n; on the first message, so a tree is running as soon as its root is.\n(define (supervise me specs)\n (task-loop me (lambda h (st msg) (supervisor-turn st msg)) (start-all specs)))\n\n; A task replacing its own semantics: the answer to a turn rather than\n; something inside one, because a change of meaning mid-computation is what is\n; most hostile to compilation. What changes is the handler, so the loop, the\n; prompt and any suspended continuation keep the semantics they were made under.\n(define (become mut state) `(become ,mut ,state))\n\n; The object language has no mutable cell, and this stands in its place: the\n; state is a task\'s, and a name for it is an address.\n;\n; (\'read) the value\n; (\'write v) \'ok, and the value is v\n;\n; Not a cell with extra steps but a different thing answering the same\n; question: it crosses a link unchanged, it can be monitored, and a write to\n; one that has died raises rather than succeeding quietly against nothing.\n;\n; No update-by-function, deliberately. A closure cannot be sent, which puts\n; read-modify-write out of reach of one message, and two are not atomic against\n; another caller; the operation belongs in the task\'s own handler instead.\n(define (ref-turn v msg)\n (if (tagged? msg \'req)\n (let ((ask (req-body msg)))\n (case (verb ask)\n ((read) (begin (reply msg v) v))\n ((write) (begin (reply msg \'ok) (cadr ask)))\n (else (begin (refuse msg (bad-request ask)) v))))\n v))\n\n; A handler rather than only a loop: a task may be a reference from its first\n; message or become one later, and which is not this code\'s business.\n(define reference (lambda h (st msg) (ref-turn st msg)))\n\n(define (ref me v) (task-loop me reference v))\n\n; A call held by somebody else: `(future to msg)` answers at once with an\n; address, and `(call f \'(read))` is the value whenever it is ready.\n;\n; The sanctioned way to serve while a call is outstanding, and a task rather\n; than a flag on the loop because that is what makes it safe - it puts a second\n; task\'s state at stake instead of the caller\'s.\n;\n; The kick is a cast to itself because a call is something a turn does and a\n; turn needs a message. It may lose the race, a task being addressable the\n; instant it is spawned, which is why the first turn hands back whatever woke\n; it rather than spending that message on starting the call.\n(define (future to msg)\n (spawn (lambda (me)\n (begin (send me \'start)\n (task-loop me\n (lambda h (st m)\n (begin (if (eq? m \'start) \'ok (send me m))\n (hand reference (call to msg))))\n 0)))))\n\n; Task 0 of a node is where a peer that has just dialled arrives, so the one\n; thing worth putting there is the one thing a peer cannot do for itself: turn\n; a name into an address.\n;\n; (\'lookup name) the address, or a raise\n; (\'register name to) \'ok, and as a cast as well\n; (\'names) the names on offer\n; (\'stop) \'ok, and the greeter ends\n;\n; Registering is also a cast because the task most likely to want it cannot\n; make a call yet: a `call` suspends into a loop, and a child naming itself on\n; its way into its own loop has nothing to suspend into.\n;\n; A rendezvous and not a guard. A frame carries the id it is for and the link\n; posts to it unchecked, so a peer can already reach any task in this heap by\n; number; trust is per link rather than per task. `register` is open to a peer\n; for the same reason - refusing it here would protect the name and not the\n; tasks, while suggesting it protected both.\n\n; Last registration wins, in place, so re-registering does not grow the table.\n(define (rebind name to table)\n (cond ((nil? table) (list (cons name to)))\n ((eq? (car (car table)) name) (cons (cons name to) (cdr table)))\n (else (cons (car table) (rebind name to (cdr table))))))\n\n; A keyed table, as a turn:\n;\n; (\'get k) the value, or a raise\n; (\'put k v) \'ok, and as a cast as well\n; (\'drop k) \'ok\n; (\'keys) the keys held\n; (\'stop) \'ok, and the task ends\n;\n; `missing` is a parameter because it is the one thing a table\'s callers see\n; that is about what the table is *for*: the greeter below is this handler with\n; `\'no-such-name`.\n(define (table-turn missing al msg)\n (case (verb msg)\n ((put) (rebind (cadr msg) (caddr msg) al))\n ((req)\n (let ((ask (req-body msg)))\n (case (verb ask)\n ((get)\n (let ((e (assq (cadr ask) al)))\n (begin (if (pair? e)\n (reply msg (cdr e))\n (refuse msg (cons missing (cadr ask))))\n al)))\n ((put)\n (begin (reply msg \'ok) (rebind (cadr ask) (caddr ask) al)))\n ((drop)\n (begin (reply msg \'ok) (without (cadr ask) al)))\n ((keys)\n (begin (reply msg (map (lambda (e) (car e)) al)) al))\n ; The answer goes out before the loop ends: a reply is a\n ; send, and a task that has stopped cannot send.\n ((stop)\n (begin (reply msg \'ok) (cons \'stop \'ok)))\n (else (begin (refuse msg (bad-request ask)) al)))))\n (else al)))\n\n(define table (lambda h (st msg) (table-turn \'no-such-key st msg)))\n\n(define (table-at me al) (task-loop me table al))\n\n; The rendezvous verbs said in the table\'s. The names differ because what they\n; mean to a caller differs: a name that is not registered is not a missing key,\n; it is a service that is not here yet.\n(define (rendezvous ask)\n (case (verb ask)\n ((lookup) `(get ,(cadr ask)))\n ((register) `(put ,(cadr ask) ,(caddr ask)))\n ((names) \'(keys))\n (else ask)))\n\n(define (greeter-turn names msg)\n (case (verb msg)\n ((register)\n (table-turn \'no-such-name names `(put ,(cadr msg) ,(caddr msg))))\n ((req)\n (table-turn \'no-such-name names\n `(req ,(req-from msg) ,(req-id msg)\n ,(rendezvous (req-body msg)))))\n (else names)))\n\n; A handler rather than a loop, because which task it runs in is not its\n; business and there are two answers. A node spawns it first, so it is task 0\n; and a dial finds it; a file run from a command line is already task 0 and\n; cannot spawn ahead of itself, so it hands its own task over instead:\n;\n; (greet self names) ; a task that is only ever the greeter\n; (hand greeter names) ; the last form of a file, as a turn\'s answer\n;\n; Registrations sent before the file reaches its last form are in the loop\'s\n; backlog by then, and go to the table rather than to the file\'s own body.\n(define greeter (lambda h (st msg) (greeter-turn st msg)))\n\n(define (greet me names) (task-loop me greeter names))\n\n; A module is an environment frame and a file is a body, so loading one is\n; reading, rewriting and evaluating - there is no loader here in the sense of a\n; mechanism, only two lines putting existing pieces in a row.\n;\n; The environment a module\'s body runs in is fixed here rather than taken from\n; the caller, and that is the whole of the design: evaluated in its importer\'s\n; scope a module would be dynamically scoped. So this is the last thing in the\n; file, and what a module sees is the language and this library entire.\n;\n; A lock file is an alist of alists, every field `(name value)`:\n;\n; ((narju-lock 1)\n; (modules\n; (json (url \"https://github.com/thorn/naj-json\")\n; (rev \"a1b2c3\")\n; (path \"github.com/thorn/naj-json\")\n; (file \"json.naj\"))))\n;\n; The version is a field beside `modules` rather than a name in it, so a module\n; may be called `modules` or `narju-lock` without colliding.\n(define (lock-field entry name)\n (let ((f (assq name entry)))\n (if (pair? f) (cadr f) (throw `(lock-field-missing ,name ,entry)))))\n\n(define (read-lock text)\n (let ((lock (car (read text))))\n (if (eq? (lock-field lock \'narju-lock) 1)\n lock\n (throw `(lock-version ,(lock-field lock \'narju-lock))))))\n\n; Keyed on the revision, so an entry never changes under a program and two\n; revisions of one repository can sit side by side. `path` is a field rather\n; than derived from `url` because the rule turning one into the other is also\n; what keeps a fetch from writing outside the root, so it lives in the one\n; place obliged to enforce it (`store_path`, `src/adapter.rs`).\n(define (module-dir root entry)\n (join \"/\" (list root (lock-field entry \'path) (lock-field entry \'rev))))\n\n; Not a `join`: the empty base is the working directory, and a `join` would\n; answer `/naj.lock`, which is a different file on every machine.\n(define (under base path)\n (if (eq? base \"\") path (join \"/\" (list base path))))\n\n(define here (environment))\n\n; `base` is the directory the file\'s module occupies, and the one thing about a\n; module its importer does not decide. Both ways out are relative to it, so a\n; module\'s paths mean the same thing wherever the store put it. Module-relative\n; rather than file-relative: resolving a sibling against the containing file\n; would make a path mean different things depending on which chain of `load`s\n; reached it.\n(define (load-in base path)\n (eval-in (cons (list (cons \'load (lambda l (p) (load-in base p)))\n (cons \'need (lambda n (name) (need-in base name))))\n here)\n (desugar-body (read (call \'(host files) `(read ,(under base path)))))))\n\n(define (load path) (load-in \"\" path))\n\n; Resolution is a local read and an `assq`: nothing here fetches, which is what\n; lets a program run under a build system with no network.\n;\n; **A module resolves against its own lock, not its importer\'s.** A name means\n; what the module that wrote it meant, and two modules may each call a\n; dependency `json` and mean different repositories. One flat lock would make a\n; name global, turning a diamond into a conflict and a conflict into version\n; solving; here a diamond is two directories. What makes that affordable is\n; that there are no cells, so two instances of one module cannot drift apart.\n(define (need-in base name)\n (let ((lock (read-lock (call \'(host files) `(read ,(under base \"naj.lock\")))))\n (root (call \'(host files) \'(root))))\n (let ((e (assq name (cdr (assq \'modules lock)))))\n (if (pair? e)\n (load-in (module-dir root (cdr e)) (lock-field (cdr e) \'file))\n (throw `(no-such-module ,name))))))\n\n(define (need name) (need-in \"\" name))\n\n; \u{2500}\u{2500} the frame \u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\u{2500}\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(list (cons \'load load)\n (cons \'need need)\n (cons \'read-lock read-lock)\n (cons \'lock-field lock-field)\n (cons \'module-dir module-dir)\n (cons \'under under)\n (cons \'not not)\n (cons \'> >)\n (cons \'<= <=)\n (cons \'>= >=)\n (cons \'= =)\n (cons \'abs abs)\n (cons \'min min)\n (cons \'max max)\n (cons \'even? even?)\n (cons \'odd? odd?)\n (cons \'cadr cadr)\n (cons \'caddr caddr)\n (cons \'cadddr cadddr)\n (cons \'tagged? tagged?)\n (cons \'verb verb)\n (cons \'assq assq)\n (cons \'without without)\n (cons \'member? member?)\n (cons \'drop-one drop-one)\n (cons \'snoc snoc)\n (cons \'length length)\n (cons \'append append)\n (cons \'reverse reverse)\n (cons \'fold fold)\n (cons \'foldr foldr)\n (cons \'map map)\n (cons \'filter filter)\n (cons \'nth nth)\n (cons \'last last)\n (cons \'str-at str-at)\n (cons \'split split)\n (cons \'join join)\n (cons \'str-find str-find)\n (cons \'str-has? str-has?)\n (cons \'starts-with? starts-with?)\n (cons \'ends-with? ends-with?)\n (cons \'space? space?)\n (cons \'str-trim str-trim)\n (cons \'assert assert)\n (cons \'check check)\n (cons \'say say)\n (cons \'call/cc call/cc)\n (cons \'prompt prompt)\n (cons \'abort abort)\n (cons \'await await)\n (cons \'await-in await-in)\n (cons \'call call)\n (cons \'call-within call-within)\n (cons \'attempt attempt)\n (cons \'interpreter interpreter)\n (cons \'environment environment)\n (cons \'eval-in eval-in)\n (cons \'handler-of handler-of)\n (cons \'with-handler with-handler)\n (cons \'spawn-with spawn-with)\n (cons \'task-loop task-loop)\n (cons \'hand hand)\n (cons \'script script)\n (cons \'supervise supervise)\n (cons \'become become)\n (cons \'req-from req-from)\n (cons \'req-id req-id)\n (cons \'req-body req-body)\n (cons \'reply reply)\n (cons \'refuse refuse)\n (cons \'bad-request bad-request)\n (cons \'reference reference)\n (cons \'ref ref)\n (cons \'future future)\n (cons \'rebind rebind)\n (cons \'table table)\n (cons \'table-at table-at)\n (cons \'greeter greeter)\n (cons \'greet greet))\n";Expand description
The library, evaluated by the evaluator rather than compiled beside it.