feat(v4.0.0): word-level access control at the prompt, as v3

- Each entry's flags cell also holds v3's four fields: denied, pinned,
  mode and a 16-bit TTL.
- compile.v4: INTERPRET checks every word it is about to execute or
  compile -- recheck at TTL 0, else count down; a denied word is refused
  with v3's line, the stack emptied and the line ended.
- capsule/acl.v4: ACL-MODE@ ACL-MODE! ACL-TTL@ ACL-TTL! ACL-ALLOW@
  ACL-ALLOW! ACL-PINNED? ACL-PIN ACL-INHERIT ACL-INIT-PRIMITIVES ACL-HEAT@
  ACL-WORD-ID, and ACL-HOOK.
- capsule/ACL.fth: v3's ACL.4th as FORTH source the node compiles; loading
  it switches access control on.
- v3 checks every execution, inside definitions too.  v4's code is native,
  so it checks a word when it is compiled as well as when interpreted; a
  call compiled while the word was allowed is not checked again.
  DECOMPOSITION.md 5.20 says so.
- ACL-HEAT@ is 0 until heat is readable (D-6).
- tests/test_host_quit.c: seven transcripts of the v3 binary; the policy
  file loaded and exercised; COLD.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

docs/v4.0.0/DECOMPOSITION.md

@@ -179,7 +179,7 @@ definition below depends on one, it says so.
 | **D-15** | Division by zero in `/` `MOD` `/MOD` `*/` `*/MOD` `M/MOD` (ruled 2026-10-04). | **Guarded: the word reports it and the line ends.** Each of these words tests its divisor before anything else. If it is zero the word prints v3's message, its own name and `: Division by zero`, takes its operands off the stack as v3 does, ends any definition that was open, prints ` ERROR` and returns to the prompt, from however deep; its caller is not returned to. `M/MOD` says so too, where v3 printed ` ERROR` alone. Source in `v4/capsule/forth.v4`; executed on the golden model's host node (2026-10-04), including transcripts of the v3 binary. `Q./` keeps D-11 (saturate and flag). `UM/MOD` and `SM/REM` are internal and unguarded: their callers have checked. What a mesh node, with no console, does on a zero divisor comes with the mesh (step 2); §4's definitions, which the mesh-node tests execute, still leave it unspecified. |
 | **D-16** | Stack overflow and underflow; `DEPTH`, `PICK`, `ROLL` (ruled 2026-10-04; revises D-2). | **Guarded: a stack fault.** Each stack counts what it holds. Before every opcode the node checks that the stacks hold what the opcode takes — including a `T` or `S` it only reads — and have room for what it leaves. If not, the opcode does nothing and the node faults exactly as for a bad address (D-14), to that kind's handler: `Stack overflow`, `Stack underflow`, `Return stack overflow`, `Return stack underflow`, then ` ERROR` and the prompt. **Every fault, D-14's included, empties both stacks**: the handler does not return, and what a word stopped part-way has left on the data stack is of no use to its caller. (v3 keeps what the failing word had not taken, and names the word: `DROP: Stack underflow`.) The fault handler is a table of five words, one per kind, each a jump (`(FAULTS)` in `v4/capsule/quit.v4`). Two registers (§7) are all a programme sees of the stacks: `DSTACK-DEPTH` and `RSTACK-DEPTH` read as the depth, and a store to one empties that stack. There is still no stack pointer and no address for a stack cell, so `SP@` and `SP!` stay retired; `.S` waits for number output to reach the capsule. The sizes were unchanged by this ruling, 10 and 9 (D-17 then deepens the host node's): one more value, or one more level of call, is now an error message where it used to be silent corruption. Executed on the golden model (2026-10-04): `tests/test_exec.c` for every opcode at every depth of both stacks, `tests/test_host_quit.c` from the prompt. |
 | **D-17** | Stack sizes on the host node (2026-10-04, following D-16). | **32 values and 32 return entries on the host node; a mesh node keeps the F18's 10 and 9.** Once the stacks are counted (D-16) their size is a parameter of the node, like its memory, and the host node is the one that runs the interpreter and the compiler underneath the user's programme: at 10 and 9 the prompt left a programme about six values, and `/` could be used only four words deep. The mechanism is the same at both sizes — top registers over a ring — and so is every word's definition. v3's stacks are deeper still. In the golden model the sizes are `V4_DATA_RING` and `V4_RET_RING` (`stack.h`), set for the host-node tests in `v4/Makefile`. |
-| **D-18** | Every other error (ruled 2026-10-04: "guard all errors"). | **A word that finds an error raises it, and the line ends there.** The word takes its own arguments off the stack and stores an error code in `NODE-ERROR` (§7). On a node with a prompt that store is a trap, a sixth kind of fault beside D-14's and D-16's: nothing after it executes, the return stack is emptied, and the prompt prints the code's message, ends any definition that was open, prints ` ERROR` and waits for the next line. Unlike the other faults it leaves the data stack as the word left it. The codes: 1 `Negative count` (`CMOVE`, `TYPE`), 2 `Not a number` (`NUMBER`), 3 `Number too long` (`HOLD` into a full buffer), 4 `Not a character` (`HOLD`), 5 `Dictionary full` (`,` `C,` `ALLOT`, any defining word), 6 `Name missing` (a defining word with nothing after it), 7 `Control structure mismatch`, 8 `Control structures too deep`, 9 `Shift count out of range`, 10 `Protected word`, 11 `Division by zero` (`Q./`), 12 `Argument out of range`, 13 `Block out of range`, 14 `No block is being loaded`, 15 `Deferred word not set`; −1 means the word printed its own message (`UNKNOWN WORD: 'xxx'`, `xxx: compile-only`). Before this ruling these set the flag and the line ran on to its end. v3 stops at once too; its messages name the word (`LOOP: missing DO`) where v4's name the fault. With the trap not attached `NODE-ERROR` is plain memory and the word returns, which is how the words are tested below the prompt. D-11, D-12 and D-13 said "set `NODE-ERROR`"; on a node with a prompt that now means this. Executed on the golden model (2026-10-04): `tests/test_exec.c`, `tests/test_host_quit.c`. |
+| **D-18** | Every other error (ruled 2026-10-04: "guard all errors"). | **A word that finds an error raises it, and the line ends there.** The word takes its own arguments off the stack and stores an error code in `NODE-ERROR` (§7). On a node with a prompt that store is a trap, a sixth kind of fault beside D-14's and D-16's: nothing after it executes, the return stack is emptied, and the prompt prints the code's message, ends any definition that was open, prints ` ERROR` and waits for the next line. Unlike the other faults it leaves the data stack as the word left it. The codes: 1 `Negative count` (`CMOVE`, `TYPE`), 2 `Not a number` (`NUMBER`), 3 `Number too long` (`HOLD` into a full buffer), 4 `Not a character` (`HOLD`), 5 `Dictionary full` (`,` `C,` `ALLOT`, any defining word), 6 `Name missing` (a defining word with nothing after it), 7 `Control structure mismatch`, 8 `Control structures too deep`, 9 `Shift count out of range`, 10 `Protected word`, 11 `Division by zero` (`Q./`), 12 `Argument out of range`, 13 `Block out of range`, 14 `No block is being loaded`, 15 `Deferred word not set`, 16 `Not a word`; −1 means the word printed its own message (`UNKNOWN WORD: 'xxx'`, `xxx: compile-only`). Before this ruling these set the flag and the line ran on to its end. v3 stops at once too; its messages name the word (`LOOP: missing DO`) where v4's name the fault. With the trap not attached `NODE-ERROR` is plain memory and the word returns, which is how the words are tested below the prompt. D-11, D-12 and D-13 said "set `NODE-ERROR`"; on a node with a prompt that now means this. Executed on the golden model (2026-10-04): `tests/test_exec.c`, `tests/test_host_quit.c`. |
 | **D-19** | Block storage on the golden model (2026-10-05). | **Four memory-mapped registers on the host node, until the mesh carries the storage service.** `BLOCK-NUMBER`, `BLOCK-ADDRESS` (the word address of 256 cells), `BLOCK-COMMAND` (a store of 1 reads the block into those cells, 2 writes it from them) and `BLOCK-STATUS` (0 when the command worked, −1 for a block the device has not got or cells not all in memory). A block is 1024 bytes: 256 cells, four bytes to a cell, the first byte lowest, at either cell width. This is the console's arrangement (§7) applied to storage; like it, it is the model's stand-in and not the mesh protocol, which §5.11 still leaves to the device node. |
 
 **Consequences of D-2 that every definition must respect.** The data stack holds 10 items and the
@@ -760,7 +760,7 @@ call would bury what it works on. A **compile-only** word may not be executed by
 `v4/capsule/forth.v4` holds the first words of the vocabulary flagged this way (`DUP`, `+`, `>R`, `I`,
 `LEAVE`, `@`, the in-line variables and so on).
 
-**The vocabulary at the prompt.** The host node's capsule is `v4/capsule/`, loaded in this order: `core.v4` (bytes, console, strings the rest rest on), `input.v4`, `dict.v4`, `codegen.v4`, `compile.v4`, `quit.v4` (the prompt, faults and errors), `forth.v4` (stack, arithmetic, division, `DEPTH` `PICK` `ROLL`), `numout.v4` (number output, `.S`), `system.v4` (vocabularies, `WORDS`, `FORGET`, `COLD`, `DEFER`), then the two files of FORTH source the node compiles itself, `editor.fth` and `tools.fth` (`SEE`); `blocks.v4` (mass storage and `LOAD`), `log.v4` (logging), `qmath.v4` (the Q48.16 words of §5.26: `Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.= Q.< Q.> Q.0= Q.MAX Q.MIN Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS Q.PRINT`; `DUMP` is in `numout.v4`) and `words.v4` (the stack, comparison, shift, double, mixed and string words of §5.1–5.9: `2SWAP 2OVER 2ROT 2>R 2R> 2R@ 2@ 2! -! 0<> 0> <> <= >= U< U> ABS MAX MIN WITHIN LSHIFT RSHIFT D- DABS D0= D0< D= D2* D2/ D< DMAX DMIN M+ M- CMOVE> MOVE FILL ERASE BLANK -TRAILING COMPARE SEARCH SCAN SKIP ?TERMINAL TRUE FALSE INVERT NOP`). Each is the definition this document gives; `tests/test_host_quit.c` runs them from the prompt against transcripts of the v3 binary. From the prompt, 122 results of the Q words printed by `Q.PRINT` — which shows all sixteen bits of a fraction — are digit for digit v3's, at both cell widths. Under D-18, `Q./` by zero and `Q.SQRT` and `Q.LOG` outside their domain leave the result D-11 and D-12 give and then raise an error (codes 11 `Division by zero` and 12 `Argument out of range`); v3 returns 0 and says nothing. As v3, `LSHIFT` and `RSHIFT` with a count that is negative or as large as the cell is wide are an error (D-18, code 9, `Shift count out of range`). `M+`, like `M-` and `M/MOD`, takes its double in the standard order, low cell first; v3 takes it low cell on top.
+**The vocabulary at the prompt.** The host node's capsule is `v4/capsule/`, loaded in this order: `core.v4` (bytes, console, strings the rest rest on), `input.v4`, `dict.v4`, `codegen.v4`, `compile.v4`, `quit.v4` (the prompt, faults and errors), `forth.v4` (stack, arithmetic, division, `DEPTH` `PICK` `ROLL`), `numout.v4` (number output, `.S`), `system.v4` (vocabularies, `WORDS`, `FORGET`, `COLD`, `DEFER`), then the two files of FORTH source the node compiles itself, `editor.fth`, `tools.fth` (`SEE`) and `ACL.fth` (the access control policy); `blocks.v4` (mass storage and `LOAD`), `log.v4` (logging), `acl.v4` (access control), `qmath.v4` (the Q48.16 words of §5.26: `Q.FROM-INT Q.TO-INT Q.1 Q.0 Q.SCALE Q.+ Q.- Q.* Q./ Q.ABS Q.NEG Q.= Q.< Q.> Q.0= Q.MAX Q.MIN Q.EXP Q.SQRT Q.LOG Q.SIN Q.COS Q.PRINT`; `DUMP` is in `numout.v4`) and `words.v4` (the stack, comparison, shift, double, mixed and string words of §5.1–5.9: `2SWAP 2OVER 2ROT 2>R 2R> 2R@ 2@ 2! -! 0<> 0> <> <= >= U< U> ABS MAX MIN WITHIN LSHIFT RSHIFT D- DABS D0= D0< D= D2* D2/ D< DMAX DMIN M+ M- CMOVE> MOVE FILL ERASE BLANK -TRAILING COMPARE SEARCH SCAN SKIP ?TERMINAL TRUE FALSE INVERT NOP`). Each is the definition this document gives; `tests/test_host_quit.c` runs them from the prompt against transcripts of the v3 binary. From the prompt, 122 results of the Q words printed by `Q.PRINT` — which shows all sixteen bits of a fraction — are digit for digit v3's, at both cell widths. Under D-18, `Q./` by zero and `Q.SQRT` and `Q.LOG` outside their domain leave the result D-11 and D-12 give and then raise an error (codes 11 `Division by zero` and 12 `Argument out of range`); v3 returns 0 and says nothing. As v3, `LSHIFT` and `RSHIFT` with a count that is negative or as large as the cell is wide are an error (D-18, code 9, `Shift count out of range`). `M+`, like `M-` and `M/MOD`, takes its double in the standard order, low cell first; v3 takes it low cell on top.
 
 **The stacks and the compiler.** The interpreter and compiler run on the same stacks as the user's
 words, with the user's values beneath them. The capsule was written for stacks of ten cells and nine
@@ -876,11 +876,37 @@ index should use them; they cost one instruction per iteration.
 
 ### 5.20 Word-level ACL
 
+On the host node, as v3 has it at its prompt (2026-10-05). Source in `v4/capsule/acl.v4` (the fields),
+`compile.v4` (the check) and `ACL.fth` (the policy, FORTH source, which is v3's `capsules/ACL.4th`).
+Executed on the golden model's host node against transcripts of the v3 binary. Between nodes, access control
+is still the router's and Hera's (§6); nothing here decides that.
+
+**The fields.** Each entry's flags cell (§5.13) also holds: bit 5 *denied*, bit 6 *pinned*, bits 8–15 the
+*mode* (0 TTL, 1 STRICT), bits 16–31 the *TTL*, a count of uses left before the next recheck. A new entry has
+all of them zero. v3's TTL is 32 bits; its own policy never sets more than 65535, which is the most 16 bits
+hold.
+
+**The check.** `INTERPRET` runs it on every word it is about to execute or compile: if the TTL is 0 the word
+is rechecked, otherwise the TTL is counted down; then a denied word is refused with v3's line —
+`WARN: ACL: denied 'xxx'` — the data stack emptied and the line ended. The recheck is the word whose address
+is in the variable `ACL-HOOK`; with none there, the word is allowed and given the longest TTL. `ACL.fth` puts
+its `ACL-RECHECK` there (v3 finds it by name each time).
+
+**Where this is weaker than v3.** v3's inner interpreter checks every execution, inside definitions too. v4
+code is native: a compiled call goes straight to its word, and no opcode asks permission. So v4 checks a
+word when it is *compiled* as well as when it is interpreted — a denied word cannot be built into anything
+new — but a call compiled while the word was allowed is not checked again when it runs. Closing that needs
+the check in the node itself (the `call` opcode), which is a hardware decision and is not taken here.
+
 | Word | Fate | Notes |
 | --- | --- | --- |
-| `ACL-MODE@` `ACL-MODE!` `ACL-TTL@` `ACL-TTL!` `ACL-ALLOW@` `ACL-ALLOW!` `ACL-PINNED?` `ACL-PIN` `ACL-INHERIT` `ACL-INIT-PRIMITIVES` | HERA | Hera holds the ACL table. In the fabric, per-message ACL checks happen in the router (§6). |
+| `ACL-MODE@` `ACL-MODE!` `ACL-TTL@` `ACL-TTL!` `ACL-ALLOW@` `ACL-ALLOW!` `ACL-PINNED?` `ACL-PIN` | CAP | As v3, on an xt. The `!` words do nothing to a pinned word. `ACL-TTL!` takes a negative count as 0 and one above 65535 as 65535; `ACL-MODE!` keeps the low byte. An xt of 0 is D-18's code 16, `Not a word`. |
-| `ACL-HEAT@` | MM |  |
+| `ACL-INHERIT` | CAP | `( src dst -- )`, as v3: `dst` takes `src`'s mode, is unpinned, allowed, TTL 0. The one word that unpins. |
-| `ACL-WORD-ID` | CC |  |
+| `ACL-INIT-PRIMITIVES` | CAP | As v3: every word that is not pinned, in every vocabulary, back to TTL mode, TTL 0, allowed. |
+| `ACL-HEAT@` | MM | `( xt -- heat )`. The node's heat counters are not readable from a programme yet (D-6): 0, so `ACL.fth` gives every word its base TTL of 256. |
+| `ACL-WORD-ID` | CC | `( xt -- n )`: a number for the word that never changes. Here that is its address. |
+| `ACL-HOOK` | CAP | Variable: the xt of the recheck word, or 0. Not in v3. |
+| `ACL-STRICT` `ACL-TTL-MODE` `ACL-TTL-COMPUTE` `ACL-RECHECK` `ACL-BOOT` `ACL-ENTRY` `HERMES-CHANNEL-OPEN?` and the constants | CC | `ACL.fth`: v3's policy file, word for word but for `ACL-BOOT`, which pins only the words v4 has (`EXEC` and `BYE` are not on this node) and sets `ACL-HOOK`. Loading the file runs `ACL-BOOT`; a system that does not load it has no access control. `COLD` removes it. |
 
 ### 5.21 Physics: benchmark and diagnostics
 

v4/capsule/ACL.fth

@@ -0,0 +1,57 @@
+\ ACL.fth -- word-level access control: the policy.
+\
+\ This is v3's capsules/ACL.4th, as FORTH source the node compiles itself.
+\ The capsule supplies the fields of an entry and the check (acl.v4,
+\ compile.v4); what is strict, how long a TTL lasts and what is pinned is
+\ decided here.  Loading this file switches access control on: its last
+\ line runs ACL-BOOT.  A system that does not load it has none.
+\
+\ The xt these words take is what FIND and ['] give: the word's code.
+
+FORTH DEFINITIONS
+
+1 CONSTANT ACL-STRICT-MODE
+0 CONSTANT ACL-TTL-MODE-VAL
+\ the TTL of a cold word, tuned 2026-06-15 on v3
+256 CONSTANT ACL-BASE-TTL
+65535 CONSTANT ACL-MAX-TTL
+
+\ ( xt -- xt )  for symmetry: the xt is the entry
+: ACL-ENTRY ;
+
+: ACL-STRICT ( xt -- )
+  DUP ACL-PINNED? IF DROP EXIT THEN  ACL-STRICT-MODE SWAP ACL-MODE! ;
+: ACL-TTL-MODE ( xt -- )
+  DUP ACL-PINNED? IF DROP EXIT THEN  ACL-TTL-MODE-VAL SWAP ACL-MODE! ;
+
+\ ( xt -- ttl )  a hotter word earns a longer TTL: heat/4 + 256, at most 65535
+: ACL-TTL-COMPUTE  ACL-HEAT@ 4 / ACL-BASE-TTL + ACL-MAX-TTL MIN ;
+
+\ ( xt -- )  what the check runs when a word's TTL is 0.
+\ STRICT: allow, and leave the TTL 0 so that every use comes back here.
+\ TTL: compute a TTL from the word's heat; allow.
+: ACL-RECHECK
+  DUP ACL-PINNED? IF DROP EXIT THEN
+  DUP ACL-MODE@ ACL-STRICT-MODE = IF
+    1 OVER ACL-ALLOW!  0 OVER ACL-TTL!  DROP EXIT
+  THEN
+  DUP ACL-TTL-COMPUTE OVER ACL-TTL!  1 SWAP ACL-ALLOW! ;
+
+\ the system CA's public key; placeholders, as in v3
+0 CONSTANT ACL-CA-KEY-LO
+0 CONSTANT ACL-CA-KEY-HI
+
+\ ( req-hi req-lo -- allow? )  the fabric asks this word whether a channel
+\ may be opened.  The default approves every request; a policy edits this.
+: HERMES-CHANNEL-OPEN?  2DROP 1 ;
+
+\ ( -- )  default fields on every word; the words that enforce the policy
+\ pinned; the recheck switched on
+: ACL-BOOT
+  ACL-INIT-PRIMITIVES
+  ['] ACL-RECHECK ACL-PIN  ['] ACL-INIT-PRIMITIVES ACL-PIN
+  ['] ACL-RECHECK ACL-HOOK !
+  LOG-INFO" ACL: active" ;
+' ACL-BOOT ACL-PIN
+
+ACL-BOOT

v4/capsule/acl.v4

@@ -0,0 +1,83 @@
+\ acl.v4 -- word-level access control: the fields of an entry.
+\
+\ DECOMPOSITION.md 5.20, as v3: ACL-MODE@ ACL-MODE! ACL-TTL@ ACL-TTL! ACL-ALLOW@
+\ ACL-ALLOW! ACL-PINNED? ACL-PIN ACL-INHERIT ACL-INIT-PRIMITIVES ACL-HEAT@
+\ ACL-WORD-ID.  These are all the capsule does itself; the policy -- what is
+\ strict, how long a TTL is, what is pinned -- is FORTH source, ACL.fth, as
+\ it is ACL.4th in v3.  The fields and the check are described in
+\ compile.v4.  Rests on compile.v4, quit.v4 and system.v4.
+\
+\ An xt of 0 is an error (code 16, "Not a word").  A pinned word's fields are
+\ not changed by the ! words: they do nothing, as in v3.
+\
+\ Constants the loader supplies:
+\   (ACL-HOOK)   word address of the variable: the xt of the recheck word, or 0
+
+\ ( xt -- xt )   refuse 0
+: (ACL-XT)   if NULL ;   NULL: drop  NODE-ERROR b! 16 !b  0 ;
+\ ( xt -- flag )   non-zero if it is pinned.  A holds the flags' address.
+: (PINNED)   -3 + a! @ 64 and ;
+
+header ACL-HOOK inline   : ACL-HOOK'   (ACL-HOOK) ;
+
+header ACL-MODE@
+: ACL-MODE@   ( xt -- mode )   (ACL-XT)  -3 + a! @  8/  255 and ;
+header ACL-TTL@
+: ACL-TTL@    ( xt -- n )      (ACL-XT)  -3 + a! @  8/ 8/  65535 and ;
+header ACL-ALLOW@
+: ACL-ALLOW@  ( xt -- flag )   (ACL-XT)  -3 + a! @  32 and  if YES  drop 0 ;   YES: drop -1 ;
+header ACL-PINNED?
+: ACL-PINNED? ( xt -- flag )   (ACL-XT)  (PINNED)  if NO  drop -1 ;   NO: ;
+header ACL-PIN
+: ACL-PIN     ( xt -- )        (ACL-XT)  -3 + a! @  64 OR  ! ;
+
+header ACL-MODE!
+: ACL-MODE!   ( mode xt -- )
+  (ACL-XT)  (PINNED) if FREE  drop drop ;
+  FREE: drop  255 and 8*  @ -65281 and  + ! ;
+\ as v3: below 0 is 0.  The TTL is sixteen bits here: above 65535 is 65535.
+header ACL-TTL!
+: ACL-TTL!    ( n xt -- )
+  (ACL-XT)  (PINNED) if FREE  drop drop ;
+  FREE: drop
+  -if POS  drop 0 jump SET
+  POS: dup -65536 and if SMALL  drop drop 65535 jump SET
+  SMALL: drop
+  SET: 8* 8*  @ 65535 and  + ! ;
+header ACL-ALLOW!
+: ACL-ALLOW!  ( flag xt -- )
+  (ACL-XT)  (PINNED) if FREE  drop drop ;
+  FREE: drop  if DENY  drop  @ -33 and ! ;
+  DENY: drop  @ 32 OR ! ;
+
+\ ( src dst -- )   as v3: dst takes src's mode; it is not pinned, its TTL
+\ is 0 and it is allowed.  This is the one word that unpins.
+header ACL-INHERIT
+: ACL-INHERIT
+  (ACL-XT) SWAP (ACL-XT)                     \ dst src
+  -3 + a! @  $FF00 and                       \ dst mode
+  SWAP -3 + a! @  255 and -97 and  + ! ;     \ the five flags, nothing else
+
+\ ( xt -- )   every entry from xt back that is not pinned: TTL mode, TTL 0,
+\ allowed
+: (ACL-INIT)
+  L: if DONE
+     dup (PINNED) if FREE  drop jump NXT
+     FREE: drop  @ 31 and !
+     NXT: -1 + a! @  jump L
+  DONE: drop ;
+\ ( -- )   as v3: do that to every word in the dictionary, in every vocabulary
+header ACL-INIT-PRIMITIVES
+: ACL-INIT-PRIMITIVES
+  (LATEST) a! @ (ACL-INIT)
+  VOC-LINK a! @
+  V: if DONE  dup a! @ (ACL-INIT)  1 + a! @  jump V
+  DONE: drop ;
+
+\ ( xt -- heat )   how often the word has been used.  The node's heat
+\ counters are not readable from a programme yet (D-6): 0.
+header ACL-HEAT@
+: ACL-HEAT@     (ACL-XT)  drop 0 ;
+\ ( xt -- n )   a number for the word that never changes: its address
+header ACL-WORD-ID
+: ACL-WORD-ID   (ACL-XT) ;

v4/capsule/compile.v4

@@ -99,6 +99,47 @@ macro ROT   push SWAP pop SWAP   endmacro
   dup -3 + a! @ 8 and if CALL  drop jump (INLINE,)
   CALL: drop jump (CALL,)
 
+\ ---- access control (5.20) -------------------------------------------------------
+\ Each entry's flags cell also holds its access control fields:
+\   bit 5 (32)      denied: the word may not be used
+\   bit 6 (64)      pinned: the fields cannot be changed
+\   bits 8 .. 15    the mode: 0 TTL, 1 STRICT
+\   bits 16 .. 31   the TTL, a count of uses left before the next recheck
+\ A new entry has all of them zero: allowed, not pinned, TTL mode, TTL 0.
+\
+\ (ACL?) is run by INTERPRET for every word it is about to execute or
+\ compile.  As v3: if the TTL is 0 the word is rechecked, otherwise the TTL
+\ is counted down; then a denied word is refused.  The recheck is the word
+\ whose address is in (ACL-HOOK) -- ACL-RECHECK, once ACL.fth has loaded --
+\ and with none there the word is allowed and given the longest TTL.
+\
+\ v3 checks every execution, inside definitions too.  v4 code is native: a
+\ compiled call goes straight to its word.  So v4 checks a word when it is
+\ compiled as well as when it is interpreted -- a denied word cannot be
+\ built into anything new -- but a call compiled while the word was allowed
+\ is not checked again.
+
+\ ( xt -- )   recheck
+: (ACL-RECHECK)
+  (ACL-HOOK) a! @ if NONE  push ex           \ call it with the xt
+  ;
+  NONE: drop  -3 + a! @  65535 and -33 and  $FFFF0000 + ! ;
+
+\ ( xt -- xt )   as above; a denied word ends the line
+: (ACL?)
+  dup -3 + a! @                              \ xt flags
+  dup $FFFF0000 and if ZERO
+    drop  -65536 + !  jump TEST              \ one use fewer
+  ZERO: drop drop  dup (ACL-RECHECK)
+  TEST: dup -3 + a! @ 32 and if OK
+  drop drop
+  $33335B1B (EMIT4) $6D (EMIT4)  $4E524157 (EMIT4) $203A (EMIT4)  $6D305B1B (EMIT4)                 \ v3's line: WARN: in yellow
+  $3A4C4341 (EMIT4) $6E656420 (EMIT4) $20646569 (EMIT4) $27 (EMIT4)
+  (.WORD)  39 EMIT CR
+  DSTACK-DEPTH b! a !b                       \ as v3, the stack is emptied
+  pop drop  jump (ABANDON)
+  OK: drop ;
+
 \ ( -- )   print the word WORD has just left
 : (.WORD)   WBUF COUNT jump TYPE
 
@@ -147,13 +188,13 @@ header INTERPRET
      dup -3 + a! @                           \ xt flags
      STATE a! @ if INTERP
        drop  1 and if COMP                   \ compiling: immediate words still run
-       drop EXECUTE  jump L
+       drop (ACL?) EXECUTE  jump L
-       COMP: drop (COMPILE,)  jump L
+       COMP: drop (ACL?) (COMPILE,)  jump L
      INTERP: drop  16 and if RUN
        drop drop  (.WORD)                    \ ": compile-only"
        $6F63203A (EMIT4) $6C69706D (EMIT4) $6E6F2D65 (EMIT4) $796C (EMIT4) CR
        jump (ABANDON)
-       RUN: drop EXECUTE  jump L
+       RUN: drop (ACL?) EXECUTE  jump L
   NUM: drop  (NUM?) if BAD
        drop
        STATE a! @ if KEEP  drop (LIT,)  jump L

v4/capsule/core.v4

@@ -17,7 +17,7 @@
 \    9 Shift count out of range      10 Protected word
 \   11 Division by zero (Q./)        12 Argument out of range
 \   13 Block out of range            14 No block is being loaded
-\   15 Deferred word not set
+\   15 Deferred word not set         16 Not a word
 \   -1 the word has printed its own message
 
 macro SWAP   over push push drop pop pop   endmacro

v4/capsule/quit.v4

@@ -99,7 +99,7 @@ header ABORT
   POS: -1 + if M1  -1 + if M2  -1 + if M3  -1 + if M4
        -1 + if M5  -1 + if M6  -1 + if M7  -1 + if M8  -1 + if M9
        -1 + if M10  -1 + if M11  -1 + if M12  -1 + if M13  -1 + if M14
-       -1 + if M15
+       -1 + if M15  -1 + if M16
        drop  2 jump (REPL)
   M1: drop  $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR  2 jump (REPL)
   M2: drop  $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR  2 jump (REPL)
@@ -116,6 +116,7 @@ header ABORT
   M13: drop  $636F6C42 (EMIT4) $756F206B (EMIT4) $666F2074 (EMIT4) $6E617220 (EMIT4) $6567 (EMIT4) CR  2 jump (REPL)
   M14: drop  $62206F4E (EMIT4) $6B636F6C (EMIT4) $20736920 (EMIT4) $6E696562 (EMIT4) $6F6C2067 (EMIT4) $64656461 (EMIT4) CR  2 jump (REPL)
   M15: drop  $65666544 (EMIT4) $64657272 (EMIT4) $726F7720 (EMIT4) $6F6E2064 (EMIT4) $65732074 (EMIT4) $74 (EMIT4) CR  2 jump (REPL)
+  M16: drop  $20746F4E (EMIT4) $6F772061 (EMIT4) $6472 (EMIT4) CR  2 jump (REPL)
 
 \ The table the loader gives the node: six words, one for each kind of
 \ fault in the node's order, each a jump.  A jump fills its word, so they

v4/capsule/system.v4

@@ -141,7 +141,7 @@ header COLD
   (BOOT)+1 a! @  (LATEST) a! !
   (BOOT) a! @ 2/ 2/  FENCE a! !
   (LATEST) CONTEXT a! !  (LATEST) CURRENT a! !  0 VOC-LINK a! !
-  10 BASE a! !  0 SCR a! !  2 (LOG-LEVEL) a! !  EMPTY-BUFFERS
+  10 BASE a! !  0 SCR a! !  2 (LOG-LEVEL) a! !  0 (ACL-HOOK) a! !  EMPTY-BUFFERS
   $54524F46 (EMIT4) $39372D48 (EMIT4) $6C6F4320 (EMIT4) $74532064 (EMIT4) $747261 (EMIT4) CR
   $74737953 (EMIT4) $69206D65 (EMIT4) $6974696E (EMIT4) $7A696C61 (EMIT4) $2E6465 (EMIT4) CR
   jump ABORT

v4/tests/host_map.h

@@ -64,6 +64,7 @@
 #define SRC          (BVARS + 8)
 #define SRC_HOOK     (BVARS + 9)
 #define STORAGE_REG  (BVARS + 10)
+#define ACL_HOOK     (BUF0_W - 6)               /* the xt of the access control recheck word, or 0 */
 #define LOG_LEVEL    (BUF0_W - 5)               /* the level at or below which a message is printed */
 #define BOOT_CELLS   (BVARS + 14)               /* (BOOT): DP and LATEST as the loader left them, 2 cells */
 #define BUF0_W       (BVARS - 2 * 256)          /* the two block buffers, 256 cells each */
@@ -132,6 +133,7 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned
     v4_text_constant(tx, "(B)", BVARS);
     v4_text_constant(tx, "(BOOT)", BOOT_CELLS);
     v4_text_constant(tx, "(LOG-LEVEL)", LOG_LEVEL);
+    v4_text_constant(tx, "(ACL-HOOK)", ACL_HOOK);
     v4_text_constant(tx, "SCR", SCR);
     v4_text_constant(tx, "BLK", BLK);
     v4_text_constant(tx, "(SRC)", SRC);

v4/tests/test_host_quit.c

@@ -102,6 +102,8 @@ static void boot_with(unsigned depth)
     n.mem[BOOT_CELLS + 1] = capsule_latest;
     n.mem[FENCE] = DICT_W;
     n.mem[LOG_LEVEL] = 2;
+    n.mem[ACL_HOOK] = 0;
+    for (v4_cell xt = capsule_latest; xt != 0; xt = n.mem[xt - 1]) n.mem[xt - 3] &= 31;   /* the capsule's words: no access control fields set */
     n.mem[CONTEXT] = LATEST;
     n.mem[CURRENT] = LATEST;
     n.mem[VOC_LINK] = 0;
@@ -165,7 +167,11 @@ static int load_source(const char *name)
         size_t len = strlen(line);
         num++;
         if (len == 0 || line[len - 1] != '\n' || len > 80) { printf("    %s line %u: too long\n", name, num); fclose(f); return 0; }
-        if (strcmp(say(line), " ok\nok> ") != 0) { printf("    %s line %u: %s", name, num, line); printf("      -> "); fputs(out, stdout); printf("\n"); fclose(f); return 0; }
+        (void)say(line);
+        /* every line is accepted: whatever it printed, it ended with " ok" and never with ERROR */
+        if (strlen(out) < 9 || strcmp(out + strlen(out) - 9, "\n ok\nok> ") != 0 || strstr(out, " ERROR\n")) {
+            if (strcmp(out, " ok\nok> ") != 0) { printf("    %s line %u: %s", name, num, line); printf("      -> "); fputs(out, stdout); printf("\n"); fclose(f); return 0; }
+        }
     }
     fclose(f);
     return n.mem[STATE] == 0;
@@ -381,6 +387,29 @@ static const transcript script[] = {
     { "Q.0 Q.LOG 65 EMIT\n-1 Q.FROM-INT Q.LOG\n", "Argument out of range\n ERROR\nok> Argument out of range\n ERROR\nok> ", 0 },
     { "7 PAD -1 DUMP 65 EMIT\n.S\n",             "Negative count\n ERROR\nok> <1> 7 \n ok\nok> ", 0 },
     { "PAD 0 DUMP\n",                            " ok\nok> ", 1 },
+    /* acl.v4: the fields of an entry, and the check, as v3 */
+    { ": FOO 65 EMIT ; ' FOO ACL-MODE@ . ' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ .\n' FOO ACL-PINNED? .\n", "0 0 -1  ok\nok> 0  ok\nok> ", 1 },
+    { ": FOO 65 EMIT ; 1 ' FOO ACL-MODE! 77 ' FOO ACL-TTL! ' FOO ACL-MODE@ .\n' FOO ACL-TTL@ . FOO ' FOO ACL-TTL@ .\n", "1  ok\nok> 77 A76  ok\nok> ", 1 },
+    { ": FOO 65 EMIT ; ' FOO ACL-PIN ' FOO ACL-PINNED? . 5 ' FOO ACL-TTL!\n0 ' FOO ACL-ALLOW! 1 ' FOO ACL-MODE!\n' FOO ACL-TTL@ . ' FOO ACL-ALLOW@ . ' FOO ACL-MODE@ .\n",
+      "-1  ok\nok>  ok\nok> 0 -1 0  ok\nok> ", 1 },
+    { ": A 1 ; : B 2 ; 1 ' A ACL-MODE! ' A ACL-PIN ' B ACL-PIN ' A ' B ACL-INHERIT\n' B ACL-MODE@ . ' B ACL-PINNED? . ' B ACL-TTL@ . ' B ACL-ALLOW@ .\n",
+      " ok\nok> 1 0 0 -1  ok\nok> ", 1 },
+    { "-5 ' DUP ACL-TTL! ' DUP ACL-TTL@ . 3 ' DUP ACL-MODE! ' DUP ACL-MODE@ .\n", "0 3  ok\nok> ", 1 },
+    { "' DUP ACL-TTL@ . ' DUP ACL-MODE@ . ' DUP ACL-ALLOW@ . ' DUP ACL-PINNED? .\n", "0 0 -1 0  ok\nok> ", 1 },
+    { ": FOO 65 EMIT ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! 1 2 FOO 66 EMIT\n.S ' FOO ACL-TTL@ .\n",
+      "\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> <0> \n4  ok\nok> ", 1 },
+    /* v4's own: the TTL is sixteen bits; a denied word cannot be compiled; with no policy a recheck allows */
+    { ": BAZ 67 EMIT ; 0 ' BAZ ACL-ALLOW! BAZ ' BAZ ACL-TTL@ . ' BAZ ACL-ALLOW@ .\n", "C65535 -1  ok\nok> ", 0 },
+    { ": FOO 65 EMIT ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! : BAR FOO ; 66 EMIT\nBAR\n' FOO ACL-TTL@ .\n",
+      "\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> UNKNOWN WORD: 'BAR'\n ERROR\nok> 4  ok\nok> ", 0 },
+    { ": FOO 65 EMIT ; : BAR FOO ; 5 ' FOO ACL-TTL! 0 ' FOO ACL-ALLOW! BAR\n", "A ok\nok> ", 0 },
+    { "99999 ' DUP ACL-TTL! ' DUP ACL-TTL@ . 65535 ' DUP ACL-TTL! ' DUP ACL-TTL@ .\n", "65535 65535  ok\nok> ", 0 },
+    { "258 ' DUP ACL-MODE! ' DUP ACL-MODE@ . 0 ' DUP ACL-ALLOW! ' DUP ACL-ALLOW@ .\n7 ' DUP ACL-ALLOW! ' DUP ACL-ALLOW@ . ' DUP ACL-TTL@ .\n", "2 0  ok\nok> -1 0  ok\nok> ", 0 },
+    { "7 0 ACL-MODE@ 65 EMIT\n0 ACL-PIN\n1 0 ACL-TTL!\n.S\n", "Not a word\n ERROR\nok> Not a word\n ERROR\nok> Not a word\n ERROR\nok> <2> 7 1 \n ok\nok> ", 0 },
+    { ": W1 ; ' W1 ACL-WORD-ID ' W1 = . ' W1 ACL-HEAT@ .\n", "-1 0  ok\nok> ", 0 },
+    { ": IM 65 EMIT ; IMMEDIATE 3 ' IM ACL-TTL! 0 ' IM ACL-ALLOW! : U IM ;\n", "\033[33mWARN: \033[0mACL: denied 'IM'\n ERROR\nok> ", 0 },
+    { ": P1 ; : P2 ; VOCABULARY VV VV DEFINITIONS : P3 ; FORTH DEFINITIONS\n9 ' P1 ACL-TTL! 1 ' P2 ACL-MODE! ' P2 ACL-PIN VV 9 ' P3 ACL-TTL!\nACL-INIT-PRIMITIVES ' P1 ACL-TTL@ . ' P2 ACL-MODE@ . ' P3 ACL-TTL@ . FORTH\n",
+      " ok\nok>  ok\nok> 0 1 0  ok\nok> ", 0 },
     /* log.v4: v3's lines, colours and all, without its time of day */
     { "LOG-LEVEL@ . LOG-ERROR . LOG-WARN . LOG-INFO . LOG-TEST . LOG-DEBUG .\n",
       "2 0 1 2 3 4  ok\nok> ", 1 },
@@ -578,8 +607,8 @@ int main(void)
     printf("v4 host prompt tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS);
 
     {
-        static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4", "words.v4", "system.v4", "qmath.v4", "blocks.v4", "log.v4" };
+        static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4", "words.v4", "system.v4", "qmath.v4", "blocks.v4", "log.v4", "acl.v4" };
-        CHECK(host_load(&tx, &n, files, 13), "the capsule assembles");
+        CHECK(host_load(&tx, &n, files, 14), "the capsule assembles");
     }
     CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
     CHECK(v4_text_here(&tx) < DICT_W, "code stays below the dictionary space");
@@ -1100,6 +1129,28 @@ int main(void)
     CHECK(is(say("SEE NOSUCH\n"), "SEE: not found\n ok\nok> ") && is(say("SEE\n"), "SEE: not found\n ok\nok> "), "a word that is not there");
     CHECK(is(say("(.\")\n"), "(.\"): compile-only\n ERROR\nok> ") && is(say("(S\")\n"), "(S\"): compile-only\n ERROR\nok> "), "the string run-time words have names but cannot be run from the prompt");
 
+    /* ---- access control with its policy loaded: ACL.fth, FORTH source ---- */
+    boot_bare();
+    CHECK(load_source("ACL.fth"), "ACL.fth compiles, every line of it");
+    CHECK(strstr(out, "\033[32mINFO: \033[0mACL: active\n") == out && n.mem[ACL_HOOK] != 0, "and its last line switches access control on");
+    CHECK(is(say(": FOO 65 EMIT ; FOO ' FOO ACL-TTL@ . FOO ' FOO ACL-TTL@ .\n"), "A256 A255  ok\nok> "), "a word's first use is rechecked and earns it a TTL, which is then counted down");
+    CHECK(is(say(": SFOO 66 EMIT ; ' SFOO ACL-STRICT SFOO SFOO ' SFOO ACL-TTL@ .\n"), "BB0  ok\nok> ") && is(say("' SFOO ACL-MODE@ .\n"), "1  ok\nok> "),
+          "a strict word is rechecked every time: its TTL stays 0");
+    CHECK(is(say("' SFOO ACL-TTL-MODE SFOO ' SFOO ACL-TTL@ . ' SFOO ACL-MODE@ .\n"), "B256 0  ok\nok> "), "and can be put back in TTL mode");
+    CHECK(is(say("' ACL-RECHECK ACL-PINNED? . ' ACL-BOOT ACL-PINNED? .\n"), "-1 -1  ok\nok> ") && is(say("' ACL-INIT-PRIMITIVES ACL-PINNED? .\n"), "-1  ok\nok> "),
+          "the policy's own words are pinned");
+    CHECK(is(say("0 ' ACL-RECHECK ACL-ALLOW! ' ACL-RECHECK ACL-STRICT ' ACL-RECHECK ACL-ALLOW@ .\n"), "-1  ok\nok> ")
+          && is(say("' ACL-RECHECK ACL-MODE@ . FOO\n"), "0 A ok\nok> "), "so they cannot be denied or changed");
+    CHECK(is(say("0 ' FOO ACL-ALLOW! 67 EMIT FOO 68 EMIT\n"), "C\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> "), "a denied word is refused while its TTL lasts");
+    CHECK(is(say("0 ' FOO ACL-TTL! FOO\n"), "A ok\nok> "), "and when its TTL runs out the policy is asked again: this one allows");
+    CHECK(is(say(": NOFOO DUP ['] FOO = IF 0 SWAP ACL-ALLOW! ELSE ACL-RECHECK THEN ;\n"), " ok\nok> ")
+          && is(say("' NOFOO ACL-HOOK ! 0 ' FOO ACL-TTL!\n"), " ok\nok> "), "a policy that denies one word");
+    CHECK(is(say("69 EMIT FOO\n"), "E\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> ") && is(say("SFOO : G FOO ;\n"), "B\033[33mWARN: \033[0mACL: denied 'FOO'\n ERROR\nok> ")
+          && is(say("1 2 + . SFOO\n"), "3 B ok\nok> "), "that word is refused, interpreted or compiled, and nothing else is");
+    CHECK(is(say("1 2 HERMES-CHANNEL-OPEN? . ACL-CA-KEY-LO . ' DUP ACL-ENTRY ' DUP = .\n"), "1 0 -1  ok\nok> "), "the rest of v3's policy file is there");
+    CHECK(is(say("COLD\n"), "FORTH-79 Cold Start\nSystem initialized.\n ok\nok> ") && n.mem[ACL_HOOK] == 0 && is(say("ACL-BOOT\n"), "UNKNOWN WORD: 'ACL-BOOT'\n ERROR\nok> "),
+          "COLD takes the policy away with everything else that was loaded");
+
     /* ---- the small system words ---- */
     boot_bare();
     CHECK(is(say("79-STANDARD .S\n"), "<0> \n ok\nok> "), "79-STANDARD is satisfied, and says nothing");